├── .gitignore ├── .merlin ├── Changelog.md ├── Makefile ├── README.markdown ├── _oasis ├── _tags ├── configure ├── docker-compose.yml ├── docker └── Dockerfile.ml ├── examples ├── build.sh └── example.ml ├── lib ├── .gitignore ├── conv │ ├── decode.ml │ ├── decode.mli │ ├── encode.ml │ ├── encode.mli │ ├── msgpack_conv.ml │ ├── msgpack_conv.mldylib │ ├── msgpack_conv.mli │ └── msgpack_conv.mllib ├── core │ ├── META │ ├── hList.ml │ ├── main.ml │ ├── msgpack.ml │ ├── msgpack.mldylib │ ├── msgpack.mli │ ├── msgpack.mllib │ ├── msgpackBase.ml │ ├── msgpackConfig.ml │ ├── msgpackCore.ml │ ├── msgpackCore.mli │ ├── pack.ml │ ├── pack.mli │ ├── serialize.ml │ └── serialize.mli └── msgpack.mlpack ├── myocamlbuild.ml ├── opam ├── proof ├── .gitignore ├── CoqBuildRule ├── DeserializeImplement.v ├── ExtractUtil.v ├── ListUtil.v ├── Main.v ├── Makefile ├── MultiByte.v ├── OCamlBase.v ├── OMakefile ├── Object.v ├── Pow.v ├── Prefix.v ├── ProofUtil.v ├── SerializeImplement.v ├── SerializeSpec.v ├── SerializedList.v ├── Soundness.v └── Util.v ├── setup.ml └── test ├── conv ├── convTest.ml └── main.ml ├── core ├── main.ml ├── packTest.ml └── serializeTest.ml └── opam └── package.sh /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.omc 3 | .omakedb 4 | .omakedb.lock 5 | *.vo 6 | *.glob 7 | *.cm[iox] 8 | *.o 9 | *.annot 10 | *.opt 11 | *.run 12 | _build 13 | *.native 14 | setup.log 15 | setup.data 16 | *.d 17 | *.swp 18 | a.out 19 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PRJ msgpack 2 | S lib/core 3 | S lib/conv 4 | B _build/lib/core 5 | B _build/lib/conv 6 | PKG ppx_meta_conv 7 | -------------------------------------------------------------------------------- /Changelog.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 5 | and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). 6 | 7 | ## 1.3.0 8 | 9 | * Update `deserialize_string` to use tail recursive map. ([#17](https://github.com/msgpack/msgpack-ocaml/pull/17)) 10 | * Rename base module to avoid conflict. ([#18](https://github.com/msgpack/msgpack-ocaml/pull/18)) 11 | * Enable msgpack to be safe-string ready. ([#19](https://github.com/msgpack/msgpack-ocaml/pull/19)) 12 | 13 | ### Breaking changes 14 | 15 | * Drop camlp4 and use ppx_meta_conv instead of meta_conv. ([#12](https://github.com/msgpack/msgpack-ocaml/pull/12), [#15](https://github.com/msgpack/msgpack-ocaml/pull/15)) 16 | * Drop OCaml before 4.01.0. ([#24](https://github.com/msgpack/msgpack-ocaml/pull/24)) 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | MsgPack for OCaml 2 | ============================== 3 | 4 | BULID 5 | ------------ 6 | 7 | ``` bash 8 | $ make 9 | $ sudo make install 10 | ``` 11 | 12 | EXAMPLE 13 | ------------ 14 | 15 | ### Serialize/Deserialize for Msgpack Object 16 | 17 | ``` ocaml 18 | (* serialize *) 19 | let bytes = 20 | Msgpack.Serialize.serialize_string (`FixArray [`PFixnum 1; `PFixnum 2; `PFixnum 3]) 21 | 22 | (* deserialize *) 23 | let obj = 24 | Msgpack.Serialize.deserialize_string bytes 25 | ``` 26 | 27 | ### Serialize/Deserialize for OCaml types (with meta_conv) 28 | 29 | ``` ocaml 30 | open Msgpack_conv 31 | 32 | type t = { 33 | int : int; 34 | str : string; 35 | } with conv(msgpack) 36 | 37 | (* serialize *) 38 | let bytes = 39 | Msgpack.Serialize.serialize_string (msgpack_of_t { int = 42; str = "ans" }) 40 | 41 | (* deserialize *) 42 | let obj = 43 | t_of_msgpack (Msgpack.Serialize.deserialize_string bytes) 44 | ``` 45 | 46 | See also, `examlpe/` 47 | 48 | DEVELOPMENT 49 | ------------ 50 | Setup development enviroment with docker: 51 | 52 | ```sh 53 | $ docker-compose build 54 | $ docker-compose run app 55 | ``` 56 | 57 | TEST 58 | ------------ 59 | 60 | ``` bash 61 | $ ocaml setup.ml -configure --enable-tests 62 | $ make test 63 | ``` 64 | 65 | PROOF 66 | ----------- 67 | 68 | If you want to use msgpack at OCaml, you need not do this section. 69 | This section for user intrested in formal verification. 70 | 71 | You need Coq 8.4 and omake. 72 | 73 | ``` bash 74 | $ cd proof 75 | $ make 76 | $ cp *.ml* ../lib/core 77 | ``` 78 | 79 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------ 2 | # Package parameters 3 | # ------------------------------------------------------------ 4 | OASISFormat: 0.3 5 | Name: msgpack 6 | Version: 1.2.1 7 | Authors: MIZUNO Hiroki 8 | License: MIT 9 | Plugins: META (0.3), DevFiles (0.3) 10 | Homepage: http://msgpack.org/ 11 | Synopsis: Msgpack library for Objective Caml 12 | Description: 13 | MessagePack is an efficient binary serialization format. 14 | If meta_conv is installed, conv module will be installed. 15 | 16 | BuildTools: ocamlbuild 17 | 18 | # ------------------------------------------------------------ 19 | # Flags 20 | # ------------------------------------------------------------ 21 | Flag all 22 | Description: build and install everything 23 | Default: false 24 | 25 | Flag core 26 | Description: Build the core library 27 | Default: true 28 | 29 | Flag conv 30 | Description: Build the meta_conv library 31 | Default$: flag(all) 32 | 33 | #------------------------------------------------------------ 34 | # Libraries 35 | #------------------------------------------------------------ 36 | Library msgpack 37 | Build$: flag(core) || flag(all) 38 | Install$: flag(core) || flag(all) 39 | Path: lib/core 40 | Modules: Msgpack 41 | InternalModules: HList, MsgpackCore, Pack, Serialize, MsgpackConfig, MsgpackBase 42 | CompiledObject: best 43 | # supress warning for Coq-extracted code 44 | ByteOpt: -g -w +a-27-39-4 -annot 45 | NativeOpt: -g -w +a-27-39-4 -annot 46 | BuildDepends: num, bytes 47 | 48 | Library msgpack_conv 49 | Build$: flag(conv) || flag(all) 50 | Install$: flag(conv) || flag(all) 51 | Path: lib/conv 52 | Modules: Msgpack_conv 53 | InternalModules: Encode, Decode 54 | CompiledObject: best 55 | ByteOpt: -g -w +a -annot 56 | NativeOpt: -g -w +a -annot 57 | 58 | # install as msgpack.conv 59 | FindlibName: conv 60 | FindlibParent: msgpack 61 | BuildDepends: ppx_meta_conv, msgpack 62 | 63 | # ------------------------------------------------------------ 64 | # Test 65 | # ------------------------------------------------------------ 66 | Executable test_core 67 | Path: test/core 68 | Build$: flag(tests) && (flag(all) || flag(core)) 69 | Install: false 70 | MainIs: main.ml 71 | BuildDepends: msgpack, oUnit 72 | CompiledObject: best 73 | 74 | Executable test_conv 75 | Path: test/conv 76 | Build$: flag(tests) && (flag(all) || flag(conv)) 77 | Install: false 78 | MainIs: main.ml 79 | BuildDepends: msgpack, msgpack.conv, oUnit 80 | CompiledObject: best 81 | 82 | Test core 83 | Run$: flag(tests) && (flag(all) || flag(core)) 84 | Command: $test_core 85 | TestTools: test_core 86 | 87 | Test conv 88 | Run$: flag(tests) && (flag(all) || flag(conv)) 89 | Command: $test_conv 90 | TestTools: test_conv 91 | 92 | # ------------------------------------------------------------ 93 | # misc 94 | # ------------------------------------------------------------ 95 | SourceRepository head 96 | Type: git 97 | Location: https://github.com/msgpack/msgpack-ocaml.git 98 | Browser: https://github.com/msgpack/msgpack-ocaml 99 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 96da846ee31bfd9f481b0de2908d8b9b) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | true: annot, bin_annot 7 | <**/.svn>: -traverse 8 | <**/.svn>: not_hygienic 9 | ".bzr": -traverse 10 | ".bzr": not_hygienic 11 | ".hg": -traverse 12 | ".hg": not_hygienic 13 | ".git": -traverse 14 | ".git": not_hygienic 15 | "_darcs": -traverse 16 | "_darcs": not_hygienic 17 | # Library msgpack 18 | "lib/core/msgpack.cmxs": use_msgpack 19 | : oasis_library_msgpack_byte 20 | : oasis_library_msgpack_byte 21 | : oasis_library_msgpack_native 22 | : oasis_library_msgpack_native 23 | : pkg_bytes 24 | : pkg_num 25 | # Library msgpack_conv 26 | "lib/conv/msgpack_conv.cmxs": use_msgpack_conv 27 | : oasis_library_msgpack_conv_byte 28 | : oasis_library_msgpack_conv_byte 29 | : oasis_library_msgpack_conv_native 30 | : oasis_library_msgpack_conv_native 31 | : pkg_bytes 32 | : pkg_num 33 | : pkg_ppx_meta_conv 34 | : use_msgpack 35 | # Executable test_core 36 | : pkg_bytes 37 | : pkg_num 38 | : pkg_oUnit 39 | : use_msgpack 40 | : pkg_bytes 41 | : pkg_num 42 | : pkg_oUnit 43 | : use_msgpack 44 | # Executable test_conv 45 | : pkg_bytes 46 | : pkg_num 47 | : pkg_oUnit 48 | : pkg_ppx_meta_conv 49 | : use_msgpack 50 | : use_msgpack_conv 51 | : pkg_bytes 52 | : pkg_num 53 | : pkg_oUnit 54 | : pkg_ppx_meta_conv 55 | : use_msgpack 56 | : use_msgpack_conv 57 | # OASIS_STOP 58 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: "2" 2 | services: 3 | app: 4 | build: 5 | context: ./docker 6 | dockerfile: Dockerfile.ml 7 | volumes: 8 | - .:/msgpack-ocaml 9 | -------------------------------------------------------------------------------- /docker/Dockerfile.ml: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-7_ocaml-4.04.0 2 | 3 | USER root 4 | 5 | RUN apt-get update && \ 6 | apt-get install libgmp-dev -y --no-install-recommends && \ 7 | apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* 8 | 9 | USER opam 10 | 11 | RUN opam update && \ 12 | opam install -y oasis ounit ppx_meta_conv ocamlfind opam-publish && \ 13 | rm -rf /home/opam/opam-repository 14 | 15 | WORKDIR /msgpack-ocaml 16 | -------------------------------------------------------------------------------- /examples/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ocamlfind ocamlc -linkpkg -package msgpack -package msgpack.conv -package ppx_meta_conv example.ml 3 | -------------------------------------------------------------------------------- /examples/example.ml: -------------------------------------------------------------------------------- 1 | (* serialize *) 2 | let bytes = 3 | Msgpack.Serialize.serialize_string ((`FixArray [`PFixnum 1; `PFixnum 2; `PFixnum 3]) : Msgpack.Serialize.t) 4 | 5 | (* deserialize *) 6 | let obj = 7 | Msgpack.Serialize.deserialize_string bytes 8 | 9 | open Msgpack_conv 10 | 11 | type t = { 12 | int : int; 13 | str : string; 14 | } [@@deriving conv{msgpack}] 15 | 16 | (* serialize *) 17 | let bytes = 18 | Msgpack.Serialize.serialize_string (msgpack_of_t { int = 42; str = "ans" }) 19 | 20 | (* deserialize *) 21 | let obj = 22 | t_of_msgpack (Msgpack.Serialize.deserialize_string bytes) 23 | 24 | 25 | -------------------------------------------------------------------------------- /lib/.gitignore: -------------------------------------------------------------------------------- 1 | runner 2 | doc 3 | -------------------------------------------------------------------------------- /lib/conv/decode.ml: -------------------------------------------------------------------------------- 1 | open MsgpackBase 2 | 3 | type t = Msgpack.Serialize.t 4 | 5 | let int = function 6 | | `PFixnum n | `Int8 n | `Int16 n 7 | | `NFixnum n | `Uint8 n | `Uint16 n -> 8 | n 9 | | `Int32 n -> 10 | Int32.to_int n 11 | | `Int64 n | `Uint32 n -> 12 | Int64.to_int n 13 | | `Uint64 n -> 14 | Big_int.int_of_big_int n 15 | | _ -> 16 | errorf "Int expected" 17 | 18 | let int32 = function 19 | | `PFixnum n | `Int8 n | `Int16 n 20 | | `NFixnum n | `Uint8 n | `Uint16 n -> 21 | Int32.of_int n 22 | | `Int32 n -> 23 | n 24 | | `Int64 n | `Uint32 n -> 25 | Int64.to_int32 n 26 | | `Uint64 n -> 27 | Big_int.int32_of_big_int n 28 | | _ -> 29 | errorf "Int expected" 30 | 31 | let int64 = function 32 | | `PFixnum n | `Int8 n | `Int16 n 33 | | `NFixnum n | `Uint8 n | `Uint16 n -> 34 | Int64.of_int n 35 | | `Int32 n -> 36 | Int64.of_int32 n 37 | | `Int64 n | `Uint32 n -> 38 | n 39 | | `Uint64 n -> 40 | Big_int.int64_of_big_int n 41 | | _ -> 42 | errorf "Int expected" 43 | 44 | let raw = function 45 | | `FixRaw xs | `Raw16 xs | `Raw32 xs -> 46 | xs 47 | | _ -> 48 | errorf "Raw expected" 49 | 50 | let str t = 51 | implode @@ raw t 52 | 53 | let array = function 54 | | `FixArray xs | `Array16 xs | `Array32 xs -> 55 | xs 56 | | _ -> 57 | errorf "Array expected" 58 | 59 | let map = function 60 | | `FixMap xs | `Map16 xs | `Map32 xs -> 61 | xs 62 | | _ -> 63 | errorf "Map expected" 64 | -------------------------------------------------------------------------------- /lib/conv/decode.mli: -------------------------------------------------------------------------------- 1 | (** Dedocer util: extract specified value from Msgpack. otherwise raise error. *) 2 | type t = Msgpack.Serialize.t 3 | 4 | val int : t -> int 5 | val int32 : t -> int32 6 | val int64 : t -> int64 7 | val map : (t * t) list -> t 8 | val str : t -> string 9 | val array : t -> t list 10 | val map : t -> (t * t) list 11 | -------------------------------------------------------------------------------- /lib/conv/encode.ml: -------------------------------------------------------------------------------- 1 | open MsgpackBase 2 | 3 | type t = Msgpack.Serialize.t 4 | 5 | let int n = 6 | if 0 <= n then begin 7 | (* positive *) 8 | if n <= 127 then 9 | `PFixnum n 10 | else if n <= 0xFF then 11 | `Uint8 n 12 | else if n <= 0xFFFF then 13 | `Uint16 n 14 | else if (Int64.of_int n) <= 0xFFFF_FFFFL then 15 | `Uint32 (Int64.of_int n) 16 | else 17 | `Uint64 (Big_int.big_int_of_int n) 18 | end else begin 19 | (* negative *) 20 | if -32 <= n then 21 | `NFixnum n 22 | else if -127 <= n then 23 | `Int8 n 24 | else if -32767 <= n then 25 | `Int16 n 26 | else if -2147483647l <= (Int32.of_int n) then 27 | `Int32 (Int32.of_int n) 28 | else 29 | `Int64 (Int64.of_int n) 30 | end 31 | 32 | let raw xs = 33 | let n = 34 | List.length xs 35 | in 36 | if n < 32 then 37 | `FixRaw xs 38 | else if n <= 0xFFFF then 39 | `Raw16 xs 40 | else 41 | `Raw32 xs 42 | 43 | let str s = 44 | raw @@ explode s 45 | 46 | let array xs = 47 | let n = 48 | List.length xs 49 | in 50 | if n < 15 then 51 | `FixArray xs 52 | else if n <= 0xFFFF then 53 | `Array16 xs 54 | else 55 | `Array32 xs 56 | 57 | let map xs = 58 | let n = 59 | List.length xs 60 | in 61 | if n < 32 then 62 | `FixMap xs 63 | else if n <= 0xFFFF then 64 | `Map16 xs 65 | else 66 | `Map32 xs 67 | 68 | -------------------------------------------------------------------------------- /lib/conv/encode.mli: -------------------------------------------------------------------------------- 1 | (** Encode util: encode value to msgpack object *) 2 | type t = Msgpack.Serialize.t 3 | 4 | val int : int -> t 5 | val str : string -> t 6 | val array : t list -> t 7 | val map : (t * t) list -> t 8 | -------------------------------------------------------------------------------- /lib/conv/msgpack_conv.ml: -------------------------------------------------------------------------------- 1 | open MsgpackBase 2 | open Meta_conv.Types 3 | 4 | include Meta_conv.Coder.Make(struct 5 | 6 | type target = Msgpack.Serialize.t 7 | 8 | let format _ = 9 | assert false 10 | 11 | module Constr = struct 12 | let tuple = 13 | Encode.array 14 | 15 | let variant _ tag = function 16 | | [] -> Encode.str tag 17 | | ts -> Encode.map [Encode.str tag, Encode.array ts] 18 | 19 | let poly_variant = 20 | variant 21 | 22 | let record _ ts = 23 | Encode.map @@ List.map (fun (key, value) -> 24 | (Encode.str key, value)) ts 25 | 26 | let object_ = 27 | record 28 | end 29 | 30 | module Deconstr = struct 31 | let tuple = 32 | Decode.array 33 | 34 | let variant _ = function 35 | | `FixRaw tag | `Raw16 tag | `Raw32 tag -> 36 | implode tag, [] 37 | | `FixMap [tag, ts] | `Map16 [tag, ts] | `Map32 [tag, ts] -> 38 | Decode.str tag, Decode.array ts 39 | | _ -> 40 | errorf "Object expected for variant" 41 | 42 | let poly_variant = 43 | variant 44 | 45 | let record _ t = 46 | Decode.map t 47 | +> List.map (fun (key, value) -> 48 | (Decode.str key, value)) 49 | 50 | let object_ = 51 | record 52 | end 53 | 54 | end) 55 | 56 | let msgpack_of_int = 57 | Encode.int 58 | 59 | let msgpack_of_unit () = 60 | `Nil 61 | 62 | let msgpack_of_bool b = 63 | `Bool b 64 | 65 | let msgpack_of_nativeint n = 66 | if Sys.word_size = 32 then 67 | `Int32 (Nativeint.to_int32 n) 68 | else 69 | `Int64 (Int64.of_nativeint n) 70 | 71 | let msgpack_of_int32 n = 72 | `Int32 n 73 | 74 | let msgpack_of_int64 n = 75 | `Int64 n 76 | 77 | let msgpack_of_float d = 78 | if Int32.to_float (Int32.of_float d) = d then 79 | (* float *) 80 | `Float d 81 | else 82 | `Double d 83 | 84 | let msgpack_of_char c = 85 | `FixRaw [ c ] 86 | 87 | let msgpack_of_string = 88 | Encode.str 89 | 90 | let msgpack_of_list f xs = 91 | Encode.array @@ List.map f xs 92 | 93 | let msgpack_of_array f xs = 94 | Encode.array @@ List.map f @@ Array.to_list xs 95 | 96 | let msgpack_of_option f = function 97 | | None -> 98 | `Nil 99 | | Some v -> 100 | f v 101 | 102 | let msgpack_of_lazy_t f x = 103 | f (Lazy.force x) 104 | 105 | let int_of_msgpack = 106 | Helper.of_deconstr Decode.int 107 | 108 | let nativeint_of_msgpack = 109 | Helper.of_deconstr (fun n -> 110 | Int64.to_nativeint @@ Decode.int64 n) 111 | 112 | let int32_of_msgpack = 113 | Helper.of_deconstr Decode.int32 114 | 115 | let int64_of_msgpack = 116 | Helper.of_deconstr Decode.int64 117 | 118 | let unit_of_msgpack = 119 | Helper.of_deconstr (function 120 | | `Nil -> () 121 | | _ -> errorf "nil expected") 122 | 123 | let bool_of_msgpack = 124 | Helper.of_deconstr (function 125 | | `Bool b -> b 126 | | _ -> errorf "bool expected") 127 | 128 | let float_of_msgpack = 129 | Helper.of_deconstr (function 130 | | `Float d | `Double d -> d 131 | | _ -> errorf "float expected") 132 | 133 | let char_of_msgpack = 134 | Helper.of_deconstr (function 135 | | `FixRaw [ c ] -> c 136 | | _ -> errorf "char expected") 137 | 138 | let string_of_msgpack : string decoder = 139 | Helper.of_deconstr Decode.str 140 | 141 | let list_of_msgpack f = 142 | Helper.list_of (function 143 | | `FixArray xs | `Array16 xs | `Array32 xs -> 144 | Some xs 145 | | _ -> 146 | None) f 147 | 148 | let array_of_msgpack f = 149 | Helper.array_of (function 150 | | `FixArray xs | `Array16 xs | `Array32 xs -> 151 | Some xs 152 | | _ -> 153 | None) f 154 | 155 | let option_of_msgpack f = 156 | Helper.option_of (function 157 | | `Nil -> Some None 158 | | v -> Some (Some v)) 159 | f 160 | 161 | let lazy_t_of_msgpack (d : ('a, Msgpack.Serialize.t) Decoder.t) : ('a lazy_t, Msgpack.Serialize.t) Decoder.t = 162 | Helper.lazy_t_of (fun (e : Msgpack.Serialize.t Meta_conv.Error.t) -> raise (Exception e)) d 163 | -------------------------------------------------------------------------------- /lib/conv/msgpack_conv.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: b2629025a7c0fe23a7a3c2f5f78a7b3a) 3 | Msgpack_conv 4 | Encode 5 | Decode 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /lib/conv/msgpack_conv.mli: -------------------------------------------------------------------------------- 1 | (** provide meta_conv types *) 2 | open Meta_conv.Types 3 | open Meta_conv.Open 4 | 5 | include Meta_conv.Types.S with type target = Msgpack.Serialize.t 6 | 7 | val msgpack_of_int : int encoder 8 | val msgpack_of_nativeint : nativeint encoder 9 | val msgpack_of_unit : unit encoder 10 | val msgpack_of_bool : bool encoder 11 | val msgpack_of_int32 : int32 encoder 12 | val msgpack_of_int64 : int64 encoder 13 | val msgpack_of_float : float encoder 14 | val msgpack_of_char : char encoder 15 | val msgpack_of_string : string encoder 16 | val msgpack_of_list : 'a encoder -> 'a list encoder 17 | val msgpack_of_array : 'a encoder -> 'a array encoder 18 | val msgpack_of_option : 'a encoder -> 'a option encoder 19 | val msgpack_of_lazy_t : 'a encoder -> 'a Lazy.t encoder 20 | 21 | val int_of_msgpack : int decoder 22 | val nativeint_of_msgpack : nativeint decoder 23 | val unit_of_msgpack : unit decoder 24 | val bool_of_msgpack : bool decoder 25 | val int32_of_msgpack : int32 decoder 26 | val int64_of_msgpack : int64 decoder 27 | val float_of_msgpack : float decoder 28 | val char_of_msgpack : char decoder 29 | val string_of_msgpack : string decoder 30 | val list_of_msgpack : 'a decoder -> 'a list decoder 31 | val array_of_msgpack : 'a decoder -> 'a array decoder 32 | val option_of_msgpack : 'a decoder -> 'a option decoder 33 | val lazy_t_of_msgpack : 'a decoder -> 'a lazy_t decoder 34 | -------------------------------------------------------------------------------- /lib/conv/msgpack_conv.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: b2629025a7c0fe23a7a3c2f5f78a7b3a) 3 | Msgpack_conv 4 | Encode 5 | Decode 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /lib/core/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 5df3d07c6392447ed9e014e0529cecbf) 3 | version = "1.2.1" 4 | description = "Msgpack library for Objective Caml" 5 | requires = "num bytes" 6 | archive(byte) = "msgpack.cma" 7 | archive(byte, plugin) = "msgpack.cma" 8 | archive(native) = "msgpack.cmxa" 9 | archive(native, plugin) = "msgpack.cmxs" 10 | exists_if = "msgpack.cma" 11 | package "conv" ( 12 | version = "1.2.1" 13 | description = "Msgpack library for Objective Caml" 14 | requires = "ppx_meta_conv msgpack" 15 | archive(byte) = "msgpack_conv.cma" 16 | archive(byte, plugin) = "msgpack_conv.cma" 17 | archive(native) = "msgpack_conv.cmxa" 18 | archive(native, plugin) = "msgpack_conv.cmxs" 19 | exists_if = "msgpack_conv.cma" 20 | ) 21 | # OASIS_STOP 22 | 23 | -------------------------------------------------------------------------------- /lib/core/hList.ml: -------------------------------------------------------------------------------- 1 | open MsgpackBase 2 | 3 | let rec last = 4 | function 5 | [] -> 6 | invalid_arg "HList.last" 7 | | [x] -> 8 | x 9 | | _::xs -> 10 | last xs 11 | 12 | let init xs = 13 | let rec init' ys = 14 | function 15 | [] -> 16 | invalid_arg "HList.init" 17 | | [_] -> 18 | List.rev ys 19 | | x::xs -> 20 | init' (x::ys) xs in 21 | init' [] xs 22 | 23 | let null = 24 | function 25 | [] -> 26 | true 27 | | _ -> 28 | false 29 | 30 | let fold_left1 f = 31 | function 32 | [] -> 33 | invalid_arg "HList.fold_left1" 34 | | x::xs -> 35 | List.fold_left f x xs 36 | 37 | let rec fold_right1 f = 38 | function 39 | [] -> 40 | invalid_arg "HList.fold_right1" 41 | | [x] -> 42 | x 43 | | x::xs -> 44 | f x (fold_right1 f xs) 45 | 46 | let conj = 47 | List.fold_left (&&) true 48 | 49 | let disj = 50 | List.fold_left (||) false 51 | 52 | let sum = 53 | List.fold_left (+) 0 54 | 55 | let product = 56 | List.fold_left ( * ) 1 57 | 58 | let concat_map f xs = 59 | List.fold_right ((@) $ f) xs [] 60 | 61 | let maximum xs = 62 | fold_left1 max xs 63 | 64 | let minimum xs = 65 | fold_left1 min xs 66 | 67 | let rec scanl f y = 68 | function 69 | [] -> 70 | [y] 71 | | x::xs -> 72 | y::scanl f (f y x) xs 73 | 74 | let scanl1 f = 75 | function 76 | [] -> 77 | [] 78 | | x::xs -> 79 | scanl f x xs 80 | 81 | let rec scanr f z = 82 | function 83 | [] -> 84 | [z] 85 | | x::xs -> 86 | match scanr f z xs with 87 | y::_ as yss -> 88 | (f x y) :: yss 89 | | _ -> 90 | failwith "must not happen" 91 | 92 | let scanr1 f = 93 | function 94 | [] -> 95 | [] 96 | | x::xs -> 97 | scanr f x xs 98 | 99 | let replicate n x = 100 | let rec loop i ys = 101 | if i = 0 then 102 | ys 103 | else 104 | loop (i-1) (x::ys) in 105 | loop n [] 106 | 107 | let rec take n = 108 | function 109 | [] -> 110 | [] 111 | | x::xs -> 112 | if n <= 0 then 113 | [] 114 | else 115 | x :: take (n - 1) xs 116 | 117 | let rec drop n = 118 | function 119 | [] -> 120 | [] 121 | | xs when n <= 0 -> 122 | xs 123 | | _::xs -> 124 | drop (n-1) xs 125 | 126 | let rec splitAt n xs = 127 | match n,xs with 128 | 0,_ | _,[] -> 129 | [],xs 130 | | _,y::ys -> 131 | let p,q = 132 | splitAt (n-1) ys in 133 | y::p,q 134 | 135 | let rec takeWhile f = 136 | function 137 | x::xs when f x -> 138 | x :: takeWhile f xs 139 | | _ -> 140 | [] 141 | 142 | let rec dropWhile f = 143 | function 144 | x::xs when f x -> 145 | dropWhile f xs 146 | | xs -> 147 | xs 148 | 149 | let rec span f = 150 | function 151 | x::xs when f x -> 152 | let ys,zs = 153 | span f xs in 154 | x::ys,zs 155 | | xs -> 156 | [],xs 157 | 158 | let break f = 159 | span (not $ f) 160 | 161 | let rec zip_with f xs ys = 162 | match xs,ys with 163 | [],_ | _,[] -> 164 | [] 165 | | x::xs',y::ys' -> 166 | (f x y)::zip_with f xs' ys' 167 | 168 | let rec zip_with3 f xs ys zs = 169 | match xs,ys,zs with 170 | [],_,_ | _,[],_ | _,_,[] -> 171 | [] 172 | | x::xs',y::ys',z::zs' -> 173 | (f x y z)::zip_with3 f xs' ys' zs' 174 | 175 | let zip xs ys = 176 | zip_with (fun x y -> (x,y)) xs ys 177 | 178 | let zip3 xs ys zs = 179 | zip_with3 (fun x y z -> (x,y,z)) xs ys zs 180 | 181 | let unzip xs = 182 | List.fold_right (fun (x,y) (xs,ys) -> (x::xs,y::ys)) xs ([],[]) 183 | 184 | let unzip3 xs = 185 | List.fold_right (fun (x,y,z) (xs,ys,zs) -> (x::xs,y::ys,z::zs)) xs ([],[],[]) 186 | 187 | let lookup x xs = 188 | try 189 | Some (List.assoc x xs) 190 | with Not_found -> 191 | None 192 | -------------------------------------------------------------------------------- /lib/core/main.ml: -------------------------------------------------------------------------------- 1 | let _ = 2 | print_endline "hello" 3 | -------------------------------------------------------------------------------- /lib/core/msgpack.ml: -------------------------------------------------------------------------------- 1 | 2 | module Serialize = Serialize 3 | module MsgpackConfig = MsgpackConfig 4 | module Pack = Pack 5 | module MsgpackCore = MsgpackCore 6 | 7 | type t = Serialize.t 8 | -------------------------------------------------------------------------------- /lib/core/msgpack.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 55cc614b1fc657973b15bfe01b640b9c) 3 | Msgpack 4 | HList 5 | MsgpackCore 6 | Pack 7 | Serialize 8 | MsgpackConfig 9 | MsgpackBase 10 | # OASIS_STOP 11 | -------------------------------------------------------------------------------- /lib/core/msgpack.mli: -------------------------------------------------------------------------------- 1 | (** MessagePack for OCaml *) 2 | 3 | 4 | (** MesagePack object. See also {{:http://redmine.msgpack.org/projects/msgpack/wiki/FormatSpec}MessagePack specification}. *) 5 | type t = 6 | [ `Bool of bool 7 | | `Nil 8 | | `PFixnum of int 9 | | `NFixnum of int 10 | | `Uint8 of int 11 | | `Uint16 of int 12 | | `Uint32 of int64 13 | | `Uint64 of Big_int.big_int 14 | | `Int8 of int 15 | | `Int16 of int 16 | | `Int32 of int32 17 | | `Int64 of int64 18 | | `Float of float 19 | | `Double of float 20 | | `FixRaw of char list 21 | | `Raw16 of char list 22 | | `Raw32 of char list 23 | | `FixArray of t list 24 | | `Array16 of t list 25 | | `Array32 of t list 26 | | `FixMap of (t * t) list 27 | | `Map16 of (t * t) list 28 | | `Map32 of (t * t) list ] 29 | 30 | (** MessagePack Serializer *) 31 | module Serialize : sig 32 | type t = 33 | [ `Bool of bool 34 | | `Nil 35 | | `PFixnum of int 36 | | `NFixnum of int 37 | | `Uint8 of int 38 | | `Uint16 of int 39 | | `Uint32 of int64 40 | | `Uint64 of Big_int.big_int 41 | | `Int8 of int 42 | | `Int16 of int 43 | | `Int32 of int32 44 | | `Int64 of int64 45 | | `Float of float 46 | | `Double of float 47 | | `FixRaw of char list 48 | | `Raw16 of char list 49 | | `Raw32 of char list 50 | | `FixArray of t list 51 | | `Array16 of t list 52 | | `Array32 of t list 53 | | `FixMap of (t * t) list 54 | | `Map16 of (t * t) list 55 | | `Map32 of (t * t) list ] 56 | 57 | 58 | 59 | (** [MessagePack.Serialize.deserialize_string str] deserialize MessagePack string [str] to MessagePack object. *) 60 | val deserialize_string : string -> t 61 | 62 | (** [MessagePack.Serialize.serialize_string obj] serialize MessagePack object [obj] to MessagePack string. *) 63 | val serialize_string : t -> string 64 | end 65 | 66 | module MsgpackConfig : sig 67 | val version : int * int * int 68 | end 69 | 70 | module MsgpackCore : sig 71 | type ascii = 72 | | Ascii of bool * bool * bool * bool * bool * bool * bool * bool 73 | 74 | type ascii8 = ascii 75 | type ascii16 = ascii8 * ascii8 76 | type ascii32 = ascii16 * ascii16 77 | type ascii64 = ascii32 * ascii32 78 | 79 | type object0 = 80 | | Bool of bool 81 | | Nil 82 | | PFixnum of ascii8 83 | | NFixnum of ascii8 84 | | Uint8 of ascii8 85 | | Uint16 of ascii16 86 | | Uint32 of ascii32 87 | | Uint64 of ascii64 88 | | Int8 of ascii8 89 | | Int16 of ascii16 90 | | Int32 of ascii32 91 | | Int64 of ascii64 92 | | Float of ascii32 93 | | Double of ascii64 94 | | FixRaw of ascii8 list 95 | | Raw16 of ascii8 list 96 | | Raw32 of ascii8 list 97 | | FixArray of object0 list 98 | | Array16 of object0 list 99 | | Array32 of object0 list 100 | | FixMap of (object0 * object0) list 101 | | Map16 of (object0 * object0) list 102 | | Map32 of (object0 * object0) list 103 | end 104 | 105 | (** Conversion MessagePack object between OCaml and Coq. *) 106 | module Pack : sig 107 | (** exception when MesagePack object is invalid form *) 108 | exception Not_conversion of string 109 | val pack : Serialize.t -> MsgpackCore.object0 110 | val unpack : MsgpackCore.object0 -> Serialize.t 111 | end 112 | 113 | -------------------------------------------------------------------------------- /lib/core/msgpack.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 55cc614b1fc657973b15bfe01b640b9c) 3 | Msgpack 4 | HList 5 | MsgpackCore 6 | Pack 7 | Serialize 8 | MsgpackConfig 9 | MsgpackBase 10 | # OASIS_STOP 11 | -------------------------------------------------------------------------------- /lib/core/msgpackBase.ml: -------------------------------------------------------------------------------- 1 | external (+>) : 'a -> ('a -> 'b) -> 'b = "%revapply" 2 | let ($) f g x = f (g x) 3 | let (!$) = Lazy.force 4 | external id : 'a -> 'a = "%identity" 5 | 6 | let uncurry f a b = f (a,b) 7 | let curry f (a,b) = f a b 8 | let flip f a b = f b a 9 | let const a _ = a 10 | 11 | let sure f = 12 | function 13 | Some x -> 14 | Some (f x) 15 | | None -> 16 | None 17 | 18 | let option f x = try Some (f x) with Not_found -> None 19 | let maybe f x = try `Val (f x) with e -> `Error e 20 | let tee f x = try ignore @@ f x; x with _ -> x 21 | 22 | type ('a,'b) either = Left of 'a | Right of 'b 23 | let left x = Left x 24 | let right x = Right x 25 | 26 | let failwithf fmt = Printf.kprintf (fun s () -> failwith s) fmt 27 | 28 | let lookup x xs = (option @@ List.assoc x) xs 29 | 30 | let string_of_list xs = 31 | Printf.sprintf "[%s]" 32 | @@ String.concat ";" xs 33 | 34 | let rec unfold f init = 35 | match f init with 36 | Some (a, b) -> a :: unfold f b 37 | | None -> [] 38 | 39 | let rec range a b = 40 | if a >= b then 41 | [] 42 | else 43 | a::range (a+1) b 44 | 45 | let rec interperse delim = 46 | function 47 | [] -> [] 48 | | [x] -> [x] 49 | | x::xs -> x::delim::interperse delim xs 50 | 51 | let map_accum_left f init xs = 52 | let f (accum,ys) x = 53 | let accum',y = 54 | f accum x in 55 | (accum',y::ys) in 56 | let accum,ys = 57 | List.fold_left f (init,[]) xs in 58 | accum,List.rev ys 59 | 60 | let rec map_accum_right f init = 61 | function 62 | [] -> 63 | init,[] 64 | | x::xs -> 65 | let (accum,ys) = 66 | map_accum_right f init xs in 67 | let (accum,y) = 68 | f accum x in 69 | accum,y::ys 70 | 71 | let rec filter_map f = 72 | function 73 | x::xs -> 74 | begin match f x with 75 | Some y -> y::filter_map f xs 76 | | None -> filter_map f xs 77 | end 78 | | [] -> 79 | [] 80 | 81 | let rec group_by f = 82 | function 83 | [] -> 84 | [] 85 | | x1::x2::xs when f x1 x2 -> 86 | begin match group_by f @@ x2::xs with 87 | y::ys -> 88 | (x1::y)::ys 89 | | _ -> 90 | failwith "must not happen" 91 | end 92 | | x::xs -> 93 | [x]::group_by f xs 94 | 95 | let index x xs = 96 | let rec loop i = function 97 | [] -> 98 | raise Not_found 99 | | y::ys -> 100 | if x = y then 101 | i 102 | else 103 | loop (i+1) ys in 104 | loop 0 xs 105 | 106 | let string_of_char = 107 | String.make 1 108 | 109 | let hex = 110 | Printf.sprintf "0x%x" 111 | 112 | let open_out_with path f = 113 | let ch = 114 | open_out_bin path in 115 | maybe f ch 116 | +> tee (fun _ -> close_out ch) 117 | +> function 118 | `Val v -> v 119 | | `Error e -> raise e 120 | 121 | let open_in_with path f = 122 | let ch = 123 | open_in_bin path in 124 | maybe f ch 125 | +> tee (fun _ -> close_in ch) 126 | +> function 127 | `Val v -> v 128 | | `Error e -> raise e 129 | 130 | let forever f () = 131 | while true do 132 | f () 133 | done 134 | 135 | let undefined = Obj.magic 42 136 | let undef = undefined 137 | 138 | let p fmt = Printf.kprintf (fun s () -> print_endline s; flush stdout) fmt 139 | 140 | let ret x _ = 141 | x 142 | 143 | let errorf fmt = 144 | Printf.ksprintf (fun s -> failwith (Printf.sprintf "Msgpack: %s" s)) fmt 145 | 146 | let explode str = 147 | let res = ref [] in 148 | String.iter (fun c -> res := c :: !res) str; 149 | List.rev !res 150 | 151 | let implode chars = 152 | let res = Bytes.create (List.length chars) in 153 | List.iteri (fun i c -> Bytes.set res i c) chars; 154 | Bytes.to_string res 155 | -------------------------------------------------------------------------------- /lib/core/msgpackConfig.ml: -------------------------------------------------------------------------------- 1 | let version = (1,2,2) 2 | -------------------------------------------------------------------------------- /lib/core/msgpackCore.mli: -------------------------------------------------------------------------------- 1 | type __ = Obj.t 2 | 3 | val negb : bool -> bool 4 | 5 | val fst : ('a1 * 'a2) -> 'a1 6 | 7 | val snd : ('a1 * 'a2) -> 'a2 8 | 9 | val app : 'a1 list -> 'a1 list -> 'a1 list 10 | 11 | type comparison = 12 | | Eq 13 | | Lt 14 | | Gt 15 | 16 | type compareSpecT = 17 | | CompEqT 18 | | CompLtT 19 | | CompGtT 20 | 21 | val compareSpec2Type : comparison -> compareSpecT 22 | 23 | type 'a compSpecT = compareSpecT 24 | 25 | val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT 26 | 27 | type 'a sig0 = 28 | 'a 29 | (* singleton inductive, whose constructor was exist *) 30 | 31 | val plus : int -> int -> int 32 | 33 | val mult : int -> int -> int 34 | 35 | val nat_iter : int -> ('a1 -> 'a1) -> 'a1 -> 'a1 36 | 37 | type positive = 38 | | XI of positive 39 | | XO of positive 40 | | XH 41 | 42 | type n = 43 | | N0 44 | | Npos of positive 45 | 46 | type reflect = 47 | | ReflectT 48 | | ReflectF 49 | 50 | val iff_reflect : bool -> reflect 51 | 52 | module Pos : 53 | sig 54 | type t = positive 55 | 56 | val succ : positive -> positive 57 | 58 | val add : positive -> positive -> positive 59 | 60 | val add_carry : positive -> positive -> positive 61 | 62 | val pred_double : positive -> positive 63 | 64 | val pred : positive -> positive 65 | 66 | val pred_N : positive -> n 67 | 68 | type mask = 69 | | IsNul 70 | | IsPos of positive 71 | | IsNeg 72 | 73 | val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 74 | 75 | val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 76 | 77 | val succ_double_mask : mask -> mask 78 | 79 | val double_mask : mask -> mask 80 | 81 | val double_pred_mask : positive -> mask 82 | 83 | val pred_mask : mask -> mask 84 | 85 | val sub_mask : positive -> positive -> mask 86 | 87 | val sub_mask_carry : positive -> positive -> mask 88 | 89 | val sub : positive -> positive -> positive 90 | 91 | val mul : positive -> positive -> positive 92 | 93 | val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 94 | 95 | val pow : positive -> positive -> positive 96 | 97 | val square : positive -> positive 98 | 99 | val div2 : positive -> positive 100 | 101 | val div2_up : positive -> positive 102 | 103 | val size_nat : positive -> int 104 | 105 | val size : positive -> positive 106 | 107 | val compare_cont : positive -> positive -> comparison -> comparison 108 | 109 | val compare : positive -> positive -> comparison 110 | 111 | val min : positive -> positive -> positive 112 | 113 | val max : positive -> positive -> positive 114 | 115 | val eqb : positive -> positive -> bool 116 | 117 | val leb : positive -> positive -> bool 118 | 119 | val ltb : positive -> positive -> bool 120 | 121 | val sqrtrem_step : 122 | (positive -> positive) -> (positive -> positive) -> (positive * mask) -> 123 | positive * mask 124 | 125 | val sqrtrem : positive -> positive * mask 126 | 127 | val sqrt : positive -> positive 128 | 129 | val gcdn : int -> positive -> positive -> positive 130 | 131 | val gcd : positive -> positive -> positive 132 | 133 | val ggcdn : int -> positive -> positive -> positive * (positive * positive) 134 | 135 | val ggcd : positive -> positive -> positive * (positive * positive) 136 | 137 | val coq_Nsucc_double : n -> n 138 | 139 | val coq_Ndouble : n -> n 140 | 141 | val coq_lor : positive -> positive -> positive 142 | 143 | val coq_land : positive -> positive -> n 144 | 145 | val ldiff : positive -> positive -> n 146 | 147 | val coq_lxor : positive -> positive -> n 148 | 149 | val shiftl_nat : positive -> int -> positive 150 | 151 | val shiftr_nat : positive -> int -> positive 152 | 153 | val shiftl : positive -> n -> positive 154 | 155 | val shiftr : positive -> n -> positive 156 | 157 | val testbit_nat : positive -> int -> bool 158 | 159 | val testbit : positive -> n -> bool 160 | 161 | val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 162 | 163 | val to_nat : positive -> int 164 | 165 | val of_nat : int -> positive 166 | 167 | val of_succ_nat : int -> positive 168 | end 169 | 170 | module Coq_Pos : 171 | sig 172 | type t = positive 173 | 174 | val succ : positive -> positive 175 | 176 | val add : positive -> positive -> positive 177 | 178 | val add_carry : positive -> positive -> positive 179 | 180 | val pred_double : positive -> positive 181 | 182 | val pred : positive -> positive 183 | 184 | val pred_N : positive -> n 185 | 186 | type mask = Pos.mask = 187 | | IsNul 188 | | IsPos of positive 189 | | IsNeg 190 | 191 | val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 192 | 193 | val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 194 | 195 | val succ_double_mask : mask -> mask 196 | 197 | val double_mask : mask -> mask 198 | 199 | val double_pred_mask : positive -> mask 200 | 201 | val pred_mask : mask -> mask 202 | 203 | val sub_mask : positive -> positive -> mask 204 | 205 | val sub_mask_carry : positive -> positive -> mask 206 | 207 | val sub : positive -> positive -> positive 208 | 209 | val mul : positive -> positive -> positive 210 | 211 | val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 212 | 213 | val pow : positive -> positive -> positive 214 | 215 | val square : positive -> positive 216 | 217 | val div2 : positive -> positive 218 | 219 | val div2_up : positive -> positive 220 | 221 | val size_nat : positive -> int 222 | 223 | val size : positive -> positive 224 | 225 | val compare_cont : positive -> positive -> comparison -> comparison 226 | 227 | val compare : positive -> positive -> comparison 228 | 229 | val min : positive -> positive -> positive 230 | 231 | val max : positive -> positive -> positive 232 | 233 | val eqb : positive -> positive -> bool 234 | 235 | val leb : positive -> positive -> bool 236 | 237 | val ltb : positive -> positive -> bool 238 | 239 | val sqrtrem_step : 240 | (positive -> positive) -> (positive -> positive) -> (positive * mask) -> 241 | positive * mask 242 | 243 | val sqrtrem : positive -> positive * mask 244 | 245 | val sqrt : positive -> positive 246 | 247 | val gcdn : int -> positive -> positive -> positive 248 | 249 | val gcd : positive -> positive -> positive 250 | 251 | val ggcdn : int -> positive -> positive -> positive * (positive * positive) 252 | 253 | val ggcd : positive -> positive -> positive * (positive * positive) 254 | 255 | val coq_Nsucc_double : n -> n 256 | 257 | val coq_Ndouble : n -> n 258 | 259 | val coq_lor : positive -> positive -> positive 260 | 261 | val coq_land : positive -> positive -> n 262 | 263 | val ldiff : positive -> positive -> n 264 | 265 | val coq_lxor : positive -> positive -> n 266 | 267 | val shiftl_nat : positive -> int -> positive 268 | 269 | val shiftr_nat : positive -> int -> positive 270 | 271 | val shiftl : positive -> n -> positive 272 | 273 | val shiftr : positive -> n -> positive 274 | 275 | val testbit_nat : positive -> int -> bool 276 | 277 | val testbit : positive -> n -> bool 278 | 279 | val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 280 | 281 | val to_nat : positive -> int 282 | 283 | val of_nat : int -> positive 284 | 285 | val of_succ_nat : int -> positive 286 | 287 | val eq_dec : positive -> positive -> bool 288 | 289 | val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 290 | 291 | val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 292 | 293 | type coq_PeanoView = 294 | | PeanoOne 295 | | PeanoSucc of positive * coq_PeanoView 296 | 297 | val coq_PeanoView_rect : 298 | 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> 299 | coq_PeanoView -> 'a1 300 | 301 | val coq_PeanoView_rec : 302 | 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> 303 | coq_PeanoView -> 'a1 304 | 305 | val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView 306 | 307 | val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView 308 | 309 | val peanoView : positive -> coq_PeanoView 310 | 311 | val coq_PeanoView_iter : 312 | 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 313 | 314 | val eqb_spec : positive -> positive -> reflect 315 | 316 | val switch_Eq : comparison -> comparison -> comparison 317 | 318 | val mask2cmp : mask -> comparison 319 | 320 | val leb_spec0 : positive -> positive -> reflect 321 | 322 | val ltb_spec0 : positive -> positive -> reflect 323 | 324 | module Private_Tac : 325 | sig 326 | 327 | end 328 | 329 | module Private_Dec : 330 | sig 331 | val max_case_strong : 332 | positive -> positive -> (positive -> positive -> __ -> 'a1 -> 'a1) -> 333 | (__ -> 'a1) -> (__ -> 'a1) -> 'a1 334 | 335 | val max_case : 336 | positive -> positive -> (positive -> positive -> __ -> 'a1 -> 'a1) -> 337 | 'a1 -> 'a1 -> 'a1 338 | 339 | val max_dec : positive -> positive -> bool 340 | 341 | val min_case_strong : 342 | positive -> positive -> (positive -> positive -> __ -> 'a1 -> 'a1) -> 343 | (__ -> 'a1) -> (__ -> 'a1) -> 'a1 344 | 345 | val min_case : 346 | positive -> positive -> (positive -> positive -> __ -> 'a1 -> 'a1) -> 347 | 'a1 -> 'a1 -> 'a1 348 | 349 | val min_dec : positive -> positive -> bool 350 | end 351 | 352 | val max_case_strong : 353 | positive -> positive -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 354 | 355 | val max_case : positive -> positive -> 'a1 -> 'a1 -> 'a1 356 | 357 | val max_dec : positive -> positive -> bool 358 | 359 | val min_case_strong : 360 | positive -> positive -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 361 | 362 | val min_case : positive -> positive -> 'a1 -> 'a1 -> 'a1 363 | 364 | val min_dec : positive -> positive -> bool 365 | end 366 | 367 | module N : 368 | sig 369 | type t = n 370 | 371 | val zero : n 372 | 373 | val one : n 374 | 375 | val two : n 376 | 377 | val succ_double : n -> n 378 | 379 | val double : n -> n 380 | 381 | val succ : n -> n 382 | 383 | val pred : n -> n 384 | 385 | val succ_pos : n -> positive 386 | 387 | val add : n -> n -> n 388 | 389 | val sub : n -> n -> n 390 | 391 | val mul : n -> n -> n 392 | 393 | val compare : n -> n -> comparison 394 | 395 | val eqb : n -> n -> bool 396 | 397 | val leb : n -> n -> bool 398 | 399 | val ltb : n -> n -> bool 400 | 401 | val min : n -> n -> n 402 | 403 | val max : n -> n -> n 404 | 405 | val div2 : n -> n 406 | 407 | val even : n -> bool 408 | 409 | val odd : n -> bool 410 | 411 | val pow : n -> n -> n 412 | 413 | val square : n -> n 414 | 415 | val log2 : n -> n 416 | 417 | val size : n -> n 418 | 419 | val size_nat : n -> int 420 | 421 | val pos_div_eucl : positive -> n -> n * n 422 | 423 | val div_eucl : n -> n -> n * n 424 | 425 | val div : n -> n -> n 426 | 427 | val modulo : n -> n -> n 428 | 429 | val gcd : n -> n -> n 430 | 431 | val ggcd : n -> n -> n * (n * n) 432 | 433 | val sqrtrem : n -> n * n 434 | 435 | val sqrt : n -> n 436 | 437 | val coq_lor : n -> n -> n 438 | 439 | val coq_land : n -> n -> n 440 | 441 | val ldiff : n -> n -> n 442 | 443 | val coq_lxor : n -> n -> n 444 | 445 | val shiftl_nat : n -> int -> n 446 | 447 | val shiftr_nat : n -> int -> n 448 | 449 | val shiftl : n -> n -> n 450 | 451 | val shiftr : n -> n -> n 452 | 453 | val testbit_nat : n -> int -> bool 454 | 455 | val testbit : n -> n -> bool 456 | 457 | val to_nat : n -> int 458 | 459 | val of_nat : int -> n 460 | 461 | val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 462 | 463 | val eq_dec : n -> n -> bool 464 | 465 | val discr : n -> positive option 466 | 467 | val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 468 | 469 | val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 470 | 471 | val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 472 | 473 | val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 474 | 475 | val leb_spec0 : n -> n -> reflect 476 | 477 | val ltb_spec0 : n -> n -> reflect 478 | 479 | module Private_BootStrap : 480 | sig 481 | 482 | end 483 | 484 | val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 485 | 486 | module Private_OrderTac : 487 | sig 488 | module IsTotal : 489 | sig 490 | 491 | end 492 | 493 | module Tac : 494 | sig 495 | 496 | end 497 | end 498 | 499 | module Private_NZPow : 500 | sig 501 | 502 | end 503 | 504 | module Private_NZSqrt : 505 | sig 506 | 507 | end 508 | 509 | val sqrt_up : n -> n 510 | 511 | val log2_up : n -> n 512 | 513 | module Private_NZDiv : 514 | sig 515 | 516 | end 517 | 518 | val lcm : n -> n -> n 519 | 520 | val eqb_spec : n -> n -> reflect 521 | 522 | val b2n : bool -> n 523 | 524 | val setbit : n -> n -> n 525 | 526 | val clearbit : n -> n -> n 527 | 528 | val ones : n -> n 529 | 530 | val lnot : n -> n -> n 531 | 532 | module Private_Tac : 533 | sig 534 | 535 | end 536 | 537 | module Private_Dec : 538 | sig 539 | val max_case_strong : 540 | n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 541 | 'a1 542 | 543 | val max_case : 544 | n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 545 | 546 | val max_dec : n -> n -> bool 547 | 548 | val min_case_strong : 549 | n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 550 | 'a1 551 | 552 | val min_case : 553 | n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 554 | 555 | val min_dec : n -> n -> bool 556 | end 557 | 558 | val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 559 | 560 | val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 561 | 562 | val max_dec : n -> n -> bool 563 | 564 | val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 565 | 566 | val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 567 | 568 | val min_dec : n -> n -> bool 569 | end 570 | 571 | val rev_append : 'a1 list -> 'a1 list -> 'a1 list 572 | 573 | val rev' : 'a1 list -> 'a1 list 574 | 575 | val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 576 | 577 | val eucl_dev : int -> int -> (int * int) 578 | 579 | type ascii = 580 | | Ascii of bool * bool * bool * bool * bool * bool * bool * bool 581 | 582 | val zero0 : ascii 583 | 584 | val one0 : ascii 585 | 586 | val shift : bool -> ascii -> ascii 587 | 588 | val ascii_of_pos : positive -> ascii 589 | 590 | val ascii_of_N : n -> ascii 591 | 592 | val ascii_of_nat : int -> ascii 593 | 594 | val n_of_digits : bool list -> n 595 | 596 | val n_of_ascii : ascii -> n 597 | 598 | val nat_of_ascii : ascii -> int 599 | 600 | val length_tailrec : 'a1 list -> int 601 | 602 | val rev_tailrec : 'a1 list -> 'a1 list 603 | 604 | val map_tailrec : ('a1 -> 'a2) -> 'a1 list -> 'a2 list 605 | 606 | val take : int -> 'a1 list -> 'a1 list 607 | 608 | val drop : int -> 'a1 list -> 'a1 list 609 | 610 | val split_at : int -> 'a1 list -> 'a1 list * 'a1 list 611 | 612 | val pair : 'a1 list -> ('a1 * 'a1) list 613 | 614 | val pow0 : int -> int 615 | 616 | val divmod : int -> int -> (int * int) 617 | 618 | type ascii8 = ascii 619 | 620 | type ascii16 = ascii8 * ascii8 621 | 622 | type ascii32 = ascii16 * ascii16 623 | 624 | type ascii64 = ascii32 * ascii32 625 | 626 | val nat_of_ascii8 : ascii -> int 627 | 628 | val ascii8_of_nat : int -> ascii 629 | 630 | val ascii16_of_nat : int -> ascii * ascii 631 | 632 | val nat_of_ascii16 : ascii16 -> int 633 | 634 | val ascii32_of_nat : int -> (ascii * ascii) * (ascii * ascii) 635 | 636 | val nat_of_ascii32 : ascii32 -> int 637 | 638 | val list_of_ascii8 : ascii8 -> ascii8 list 639 | 640 | val list_of_ascii16 : ascii16 -> ascii8 list 641 | 642 | val list_of_ascii32 : ascii32 -> ascii8 list 643 | 644 | val list_of_ascii64 : ascii64 -> ascii8 list 645 | 646 | type object0 = 647 | | Bool of bool 648 | | Nil 649 | | PFixnum of ascii8 650 | | NFixnum of ascii8 651 | | Uint8 of ascii8 652 | | Uint16 of ascii16 653 | | Uint32 of ascii32 654 | | Uint64 of ascii64 655 | | Int8 of ascii8 656 | | Int16 of ascii16 657 | | Int32 of ascii32 658 | | Int64 of ascii64 659 | | Float of ascii32 660 | | Double of ascii64 661 | | FixRaw of ascii8 list 662 | | Raw16 of ascii8 list 663 | | Raw32 of ascii8 list 664 | | FixArray of object0 list 665 | | Array16 of object0 list 666 | | Array32 of object0 list 667 | | FixMap of (object0 * object0) list 668 | | Map16 of (object0 * object0) list 669 | | Map32 of (object0 * object0) list 670 | 671 | val serialize_rev_list : 672 | (object0 -> ascii8 list -> ascii8 list) -> object0 list -> ascii8 list -> 673 | ascii8 list 674 | 675 | val serialize_rev_kvs : 676 | (object0 -> ascii8 list -> ascii8 list) -> (object0 * object0) list -> 677 | ascii8 list -> ascii8 list 678 | 679 | val serialize_rev : object0 -> ascii list -> ascii8 list 680 | 681 | val compact : object0 list -> ascii8 list 682 | 683 | val deserialize : int -> ascii8 list -> object0 list 684 | 685 | -------------------------------------------------------------------------------- /lib/core/pack.ml: -------------------------------------------------------------------------------- 1 | open MsgpackBase 2 | open MsgpackCore 3 | 4 | exception Not_conversion of string 5 | 6 | type t = 7 | [ `Bool of bool 8 | | `Nil 9 | | `PFixnum of int 10 | | `NFixnum of int 11 | | `Uint8 of int 12 | | `Uint16 of int 13 | | `Uint32 of int64 14 | | `Uint64 of Big_int.big_int 15 | | `Int8 of int 16 | | `Int16 of int 17 | | `Int32 of int32 18 | | `Int64 of int64 19 | | `Float of float 20 | | `Double of float 21 | | `FixRaw of char list 22 | | `Raw16 of char list 23 | | `Raw32 of char list 24 | | `FixArray of t list 25 | | `Array16 of t list 26 | | `Array32 of t list 27 | | `FixMap of (t * t) list 28 | | `Map16 of (t * t) list 29 | | `Map32 of (t * t) list ] 30 | 31 | let map f l = 32 | List.rev (List.rev_map f l) 33 | 34 | let ascii8 n = 35 | Ascii(n land 0b0000_0001 <> 0, 36 | n land 0b0000_0010 <> 0, 37 | n land 0b0000_0100 <> 0, 38 | n land 0b0000_1000 <> 0, 39 | n land 0b0001_0000 <> 0, 40 | n land 0b0010_0000 <> 0, 41 | n land 0b0100_0000 <> 0, 42 | n land 0b1000_0000 <> 0) 43 | 44 | let ascii8_of_char c = 45 | c +> Char.code +> ascii8 46 | 47 | let ascii16 n = 48 | (ascii8 (n lsr 8), ascii8 n) 49 | 50 | let ascii32 n = 51 | (ascii16 (Int64.to_int (Int64.shift_right_logical n 16)), 52 | ascii16 (Int64.to_int (Int64.logand n 0xFFFFL))) 53 | 54 | let ascii64 n = 55 | let open Big_int in 56 | let x = 57 | shift_right_big_int n 32 58 | +> int64_of_big_int 59 | +> ascii32 in 60 | let y = 61 | and_big_int n (big_int_of_int64 0xFFFF_FFFFL) 62 | +> int64_of_big_int 63 | +> ascii32 in 64 | (x, y) 65 | 66 | let ascii32_of_int32 n = 67 | (ascii16 (Int32.to_int (Int32.shift_right_logical n 16)), 68 | ascii16 (Int32.to_int n)) 69 | 70 | let ascii64_of_int64 n = 71 | (ascii32 (Int64.shift_right_logical n 32), 72 | ascii32 n) 73 | 74 | let not_conversion msg = 75 | raise @@ Not_conversion msg 76 | 77 | let rec pack = function 78 | `Nil -> 79 | Nil 80 | | `Bool b -> 81 | Bool b 82 | | `PFixnum n -> 83 | if 0 <= n && n < 128 then 84 | PFixnum (ascii8 n) 85 | else 86 | not_conversion "pfixnum" 87 | | `NFixnum n -> 88 | if -32 <= n && n < 0 then 89 | NFixnum (ascii8 n) 90 | else 91 | not_conversion "nfixnum" 92 | | `Uint8 n -> 93 | if 0 <= n && n <= 0xFF then 94 | Uint8 (ascii8 n) 95 | else 96 | not_conversion "uint8" 97 | | `Uint16 n -> 98 | if 0 <= n && n <= 0xFF_FF then 99 | Uint16 (ascii16 n) 100 | else 101 | not_conversion "uint16" 102 | | `Uint32 n -> 103 | if 0L <= n && n <= 0xFFFF_FFFFL then 104 | Uint32 (ascii32 n) 105 | else 106 | not_conversion "uint32" 107 | | `Uint64 n -> 108 | let open Big_int in 109 | let (<=%) = le_big_int in 110 | let (<<) = shift_left_big_int in 111 | if zero_big_int <=% n && n <=% (unit_big_int << 64) then 112 | Uint64 (ascii64 n) 113 | else 114 | not_conversion "uint64" 115 | | `Int8 n -> 116 | if -127 <= n && n <= 128 then 117 | Int8 (ascii8 n) 118 | else 119 | not_conversion "int8" 120 | | `Int16 n -> 121 | if -32767 <= n && n <= 32768 then 122 | Int16 (ascii16 n) 123 | else 124 | not_conversion "int16" 125 | | `Int32 n -> 126 | Int32 (ascii16 (Int32.to_int (Int32.shift_right_logical n 16)), 127 | ascii16 (Int32.to_int n)) 128 | | `Int64 n -> 129 | Int64 (ascii64_of_int64 n) 130 | | `Float n -> 131 | Float (ascii32_of_int32 @@ Int32.bits_of_float n) 132 | | `Double n -> 133 | Double (ascii64_of_int64 @@ Int64.bits_of_float n) 134 | | `FixRaw cs -> 135 | FixRaw (map ascii8_of_char cs) 136 | | `Raw16 cs -> 137 | Raw16 (map ascii8_of_char cs) 138 | | `Raw32 cs -> 139 | Raw32 (map ascii8_of_char cs) 140 | | `FixArray xs -> 141 | FixArray (map pack xs) 142 | | `Array16 xs -> 143 | Array16 (map pack xs) 144 | | `Array32 xs -> 145 | Array32 (map pack xs) 146 | | `FixMap xs -> 147 | FixMap (map (fun (x,y) -> (pack x, pack y)) xs) 148 | | `Map16 xs -> 149 | Map16 (map (fun (x,y) -> (pack x, pack y)) xs) 150 | | `Map32 xs -> 151 | Map32 (map (fun (x,y) -> (pack x, pack y)) xs) 152 | 153 | let of_ascii8 (Ascii(b1,b2,b3,b4,b5,b6,b7,b8)) = 154 | List.fold_left (fun x y -> 2 * x + (if y then 1 else 0)) 0 [ b8; b7; b6; b5; b4; b3; b2; b1 ] 155 | 156 | let char_of_ascii8 c = 157 | c +> of_ascii8 +> Char.chr 158 | 159 | let of_ascii16 (c1, c2) = 160 | of_ascii8 c1 lsl 8 + of_ascii8 c2 161 | 162 | let of_ascii32 (c1,c2) = 163 | let (+%) = Int64.add in 164 | let (<<) = Int64.shift_left in 165 | ((Int64.of_int (of_ascii16 c1)) << 16) +% Int64.of_int (of_ascii16 c2) 166 | 167 | let int32_of_ascii32 (c1,c2) = 168 | let (+%) = Int32.add in 169 | let (<<) = Int32.shift_left in 170 | ((Int32.of_int @@ of_ascii16 c1) << 16) +% (Int32.of_int @@ of_ascii16 c2) 171 | 172 | let int64_of_ascii64 (c1,c2) = 173 | let (+%) = Int64.add in 174 | let (<<) = Int64.shift_left in 175 | (of_ascii32 c1 << 32) +% (of_ascii32 c2) 176 | 177 | let of_ascii64 (c1, c2) = 178 | let open Big_int in 179 | let (+%) = add_big_int in 180 | let (<<) = shift_left_big_int in 181 | ((big_int_of_int64 @@ of_ascii32 c1) << 32) +% (big_int_of_int64 @@ of_ascii32 c2) 182 | 183 | let int width n = 184 | (n lsl (Sys.word_size-width-1)) asr (Sys.word_size-width-1);; 185 | 186 | let rec unpack = function 187 | | Nil -> `Nil 188 | | Bool b -> `Bool b 189 | | PFixnum c -> `PFixnum (of_ascii8 c) 190 | | NFixnum c -> `NFixnum (int 8 @@ of_ascii8 c) 191 | | Uint8 c -> `Uint8 (of_ascii8 c) 192 | | Uint16 c -> `Uint16 (of_ascii16 c) 193 | | Uint32 c -> `Uint32 (of_ascii32 c) 194 | | Uint64 c -> `Uint64 (of_ascii64 c) 195 | | Int8 c -> `Int8 (int 8 @@ of_ascii8 c) 196 | | Int16 c -> `Int16 (int 16 @@ of_ascii16 c) 197 | | Int32 c -> `Int32 (int32_of_ascii32 c) 198 | | Int64 c -> `Int64 (int64_of_ascii64 c) 199 | | Float c -> `Float (Int32.float_of_bits (int32_of_ascii32 c)) 200 | | Double c -> `Double (Int64.float_of_bits (int64_of_ascii64 c)) 201 | | FixRaw cs -> `FixRaw (map char_of_ascii8 cs) 202 | | Raw16 cs -> `Raw16 (map char_of_ascii8 cs) 203 | | Raw32 cs -> `Raw32 (map char_of_ascii8 cs) 204 | | FixArray xs -> `FixArray (map unpack xs) 205 | | Array16 xs -> `Array16 (map unpack xs) 206 | | Array32 xs -> `Array32 (map unpack xs) 207 | | FixMap xs -> `FixMap (map (fun (x,y) -> (unpack x, unpack y)) xs) 208 | | Map16 xs -> `Map16 (map (fun (x,y) -> (unpack x, unpack y)) xs) 209 | | Map32 xs -> `Map32 (map (fun (x,y) -> (unpack x, unpack y)) xs) 210 | -------------------------------------------------------------------------------- /lib/core/pack.mli: -------------------------------------------------------------------------------- 1 | exception Not_conversion of string 2 | 3 | type t = 4 | [ `Bool of bool 5 | | `Nil 6 | | `PFixnum of int 7 | | `NFixnum of int 8 | | `Uint8 of int 9 | | `Uint16 of int 10 | | `Uint32 of int64 11 | | `Uint64 of Big_int.big_int 12 | | `Int8 of int 13 | | `Int16 of int 14 | | `Int32 of int32 15 | | `Int64 of int64 16 | | `Float of float 17 | | `Double of float 18 | | `FixRaw of char list 19 | | `Raw16 of char list 20 | | `Raw32 of char list 21 | | `FixArray of t list 22 | | `Array16 of t list 23 | | `Array32 of t list 24 | | `FixMap of (t * t) list 25 | | `Map16 of (t * t) list 26 | | `Map32 of (t * t) list ] 27 | 28 | val pack : t -> MsgpackCore.object0 29 | val unpack : MsgpackCore.object0 -> t 30 | 31 | val char_of_ascii8 : MsgpackCore.ascii -> char 32 | val ascii8_of_char : char -> MsgpackCore.ascii 33 | -------------------------------------------------------------------------------- /lib/core/serialize.ml: -------------------------------------------------------------------------------- 1 | open MsgpackBase 2 | 3 | type t = Pack.t 4 | 5 | let deserialize_string str = 6 | str 7 | +> explode 8 | +> List.rev_map Pack.ascii8_of_char 9 | +> List.rev 10 | +> MsgpackCore.deserialize 0 11 | +> List.hd 12 | +> Pack.unpack 13 | 14 | let serialize_string obj = 15 | obj 16 | +> Pack.pack 17 | +> (fun objs -> MsgpackCore.serialize_rev objs []) 18 | +> List.rev_map Pack.char_of_ascii8 19 | +> implode 20 | -------------------------------------------------------------------------------- /lib/core/serialize.mli: -------------------------------------------------------------------------------- 1 | type t = Pack.t 2 | 3 | val deserialize_string : string -> t 4 | val serialize_string : t -> string 5 | -------------------------------------------------------------------------------- /lib/msgpack.mlpack: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 4d381f1cfde48921efc7d50e536b0023) 3 | Serialize 4 | Open 5 | Config 6 | HList 7 | MsgpackCore 8 | Pack 9 | # OASIS_STOP 10 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "msgpack" 3 | version: "1.3.0" 4 | maintainer: "mzp " 5 | author: "mzp " 6 | homepage: "http://github.com/msgpack/msgpack-ocaml/" 7 | dev-repo: "https://github.com/msgpack/msgpack-ocaml.git" 8 | bug-reports: "https://github.com/msgpack/msgpack-ocaml/issues" 9 | build: [ 10 | ["ocaml" "setup.ml" "-configure" "--prefix" prefix "--%{ppx_meta_conv:enable}%-conv"] 11 | ["ocaml" "setup.ml" "-build"] 12 | ] 13 | build-test: [ 14 | ["ocaml" "setup.ml" "-configure" "--enable-tests"] 15 | ["ocaml" "setup.ml" "-build"] 16 | ["ocaml" "setup.ml" "-test"] 17 | ] 18 | install: [ 19 | ["ocaml" "setup.ml" "-install"] 20 | ] 21 | remove: [ 22 | ["ocamlfind" "remove" "msgpack"] 23 | ] 24 | available: [ ocaml-version >= "4.01.0" ] 25 | depends: [ 26 | "ocamlfind" {build} 27 | "ocamlbuild" {build} 28 | "base-num" 29 | "base-bytes" 30 | "ounit" {test} 31 | ] 32 | depopts: ["ppx_meta_conv"] 33 | -------------------------------------------------------------------------------- /proof/.gitignore: -------------------------------------------------------------------------------- 1 | msgpackCore.ml 2 | msgpackCore.mli 3 | -------------------------------------------------------------------------------- /proof/CoqBuildRule: -------------------------------------------------------------------------------- 1 | public.COQC = coqc 2 | public.COQC_FLAGS = 3 | public.COQLIB = $(shell coqc -where) 4 | public.COQDEP = coqdep -w -coqlib $`(COQLIB) -I . 5 | 6 | public.CoqProof(files) = 7 | vo=$(addsuffix .vo,$(files)) 8 | value $(vo) 9 | 10 | %.vo %.glob: %.v 11 | $(COQC) $(COQC_FLAGS) $< 12 | 13 | .SCANNER: %.vo: %.v 14 | $(COQDEP) $< 15 | -------------------------------------------------------------------------------- /proof/DeserializeImplement.v: -------------------------------------------------------------------------------- 1 | Require Import Ascii List. 2 | Require Import ListUtil Object MultiByte Util SerializeSpec Pow SerializedList ProofUtil. 3 | 4 | Open Scope char_scope. 5 | 6 | Definition compact (xs : list object) : list ascii8 := 7 | map_tailrec (fun x => match x with 8 | | FixRaw [x] => x 9 | | _ => "0" 10 | end) 11 | xs. 12 | 13 | Fixpoint deserialize (n : nat) (xs : list ascii8) {struct xs} := 14 | match n with 15 | | 0 => 16 | match xs with 17 | | "192" :: ys => 18 | Nil::deserialize 0 ys 19 | | "194" :: ys => 20 | Bool false :: deserialize 0 ys 21 | | "195" :: ys => 22 | Bool true :: deserialize 0 ys 23 | | Ascii b1 b2 b3 b4 b5 b6 b7 false :: ys => 24 | PFixnum (Ascii b1 b2 b3 b4 b5 b6 b7 false) :: deserialize 0 ys 25 | | (Ascii b1 b2 b3 b4 b5 true true true) :: ys => 26 | NFixnum (Ascii b1 b2 b3 b4 b5 true true true) :: deserialize 0 ys 27 | | "204" :: c1 :: ys => 28 | Uint8 c1 :: deserialize 0 ys 29 | | "205" :: c1 :: c2 :: ys => 30 | Uint16 (c1, c2) :: deserialize 0 ys 31 | | "206" :: c1 :: c2 :: c3 :: c4 :: ys => 32 | Uint32 ((c1, c2), (c3, c4)) :: deserialize 0 ys 33 | | "207" :: c1 :: c2 :: c3 :: c4 :: c5 :: c6 :: c7 :: c8 :: ys => 34 | Uint64 (((c1, c2), (c3, c4)), ((c5, c6), (c7, c8))) :: deserialize 0 ys 35 | | "208" :: c1 :: ys => 36 | Int8 c1 :: deserialize 0 ys 37 | | "209" :: c1 :: c2 :: ys => 38 | Int16 (c1, c2) :: deserialize 0 ys 39 | | "210" :: c1 :: c2 :: c3 :: c4 :: ys => 40 | Int32 ((c1, c2), (c3, c4)) :: deserialize 0 ys 41 | | "211" :: c1 :: c2 :: c3 :: c4 :: c5 :: c6 :: c7 :: c8 :: ys => 42 | Int64 (((c1, c2), (c3, c4)), ((c5, c6), (c7, c8))) :: deserialize 0 ys 43 | | "202" :: c1 :: c2 :: c3 :: c4 :: ys => 44 | Float ((c1,c2), (c3, c4)) :: deserialize 0 ys 45 | | "203" :: c1 :: c2 :: c3 :: c4 :: c5 :: c6 :: c7 :: c8 :: ys => 46 | Double (((c1, c2), (c3, c4)), ((c5, c6), (c7, c8))) :: deserialize 0 ys 47 | | Ascii b1 b2 b3 b4 b5 true false true :: ys => 48 | let n := 49 | nat_of_ascii8 (Ascii b1 b2 b3 b4 b5 false false false) in 50 | let (zs, ws) := 51 | split_at n @@ deserialize n ys in 52 | FixRaw (compact zs) :: ws 53 | | "218" :: s1 :: s2 :: ys => 54 | let n := 55 | nat_of_ascii16 (s1,s2) in 56 | let (zs, ws) := 57 | split_at n @@ deserialize n ys in 58 | Raw16 (compact zs) :: ws 59 | | "219" :: s1 :: s2 :: s3 :: s4 :: ys => 60 | let n := 61 | nat_of_ascii32 ((s1,s2),(s3,s4)) in 62 | let (zs, ws) := 63 | split_at n @@ deserialize n ys in 64 | Raw32 (compact zs) :: ws 65 | | Ascii b1 b2 b3 b4 true false false true :: ys => 66 | let n := 67 | nat_of_ascii8 (Ascii b1 b2 b3 b4 false false false false) in 68 | let (zs, ws) := 69 | split_at n @@ deserialize 0 ys in 70 | FixArray zs :: ws 71 | | "220" :: s1 :: s2 :: ys => 72 | let n := 73 | nat_of_ascii16 (s1,s2) in 74 | let (zs, ws) := 75 | split_at n @@ deserialize 0 ys in 76 | Array16 zs :: ws 77 | | "221" :: s1 :: s2 :: s3 :: s4 :: ys => 78 | let n := 79 | nat_of_ascii32 ((s1, s2), (s3, s4)) in 80 | let (zs, ws) := 81 | split_at n @@ deserialize 0 ys in 82 | Array32 zs :: ws 83 | | Ascii b1 b2 b3 b4 false false false true :: ys => 84 | let n := 85 | nat_of_ascii8 (Ascii b1 b2 b3 b4 false false false false) in 86 | let (zs, ws) := 87 | split_at (2 * n) @@ deserialize 0 ys in 88 | FixMap (pair zs) :: ws 89 | | "222" :: s1 :: s2 :: ys => 90 | let n := 91 | nat_of_ascii16 (s1,s2) in 92 | let (zs, ws) := 93 | split_at (2 * n) @@ deserialize 0 ys in 94 | Map16 (pair zs) :: ws 95 | | "223" :: s1 :: s2 :: s3 :: s4 :: ys => 96 | let n := 97 | nat_of_ascii32 ((s1, s2), (s3, s4)) in 98 | let (zs, ws) := 99 | split_at (2 * n) @@ deserialize 0 ys in 100 | Map32 (pair zs) :: ws 101 | | _ => 102 | [] 103 | end 104 | | S m => 105 | match xs with 106 | | y::ys => FixRaw [ y ]::deserialize m ys 107 | | _ => [] 108 | end 109 | end. 110 | 111 | Definition DeserializeCorrect os bs := 112 | SerializedList os bs -> 113 | deserialize 0 bs = os. 114 | 115 | Lemma correct_bot : 116 | DeserializeCorrect [] []. 117 | Proof with auto. 118 | unfold DeserializeCorrect... 119 | Qed. 120 | 121 | Lemma correct_nil : forall os bs, 122 | DeserializeCorrect os bs -> 123 | DeserializeCorrect (Nil :: os) ("192"::bs). 124 | Proof with auto. 125 | unfold DeserializeCorrect. 126 | intros. 127 | inversion H0. 128 | apply H in H3. 129 | rewrite <- H3... 130 | Qed. 131 | 132 | Lemma correct_false: forall os bs, 133 | DeserializeCorrect os bs -> 134 | DeserializeCorrect ((Bool false) :: os) ("194"::bs). 135 | Proof with auto. 136 | unfold DeserializeCorrect. 137 | intros. 138 | inversion H0. 139 | apply H in H3. 140 | rewrite <- H3... 141 | Qed. 142 | 143 | Lemma correct_true: forall os bs, 144 | DeserializeCorrect os bs -> 145 | DeserializeCorrect ((Bool true) :: os) ("195"::bs). 146 | Proof with auto. 147 | unfold DeserializeCorrect. 148 | intros. 149 | inversion H0. 150 | apply H in H3. 151 | rewrite <- H3... 152 | Qed. 153 | 154 | Lemma correct_pfixnum: forall os bs x1 x2 x3 x4 x5 x6 x7, 155 | DeserializeCorrect os bs -> 156 | DeserializeCorrect ((PFixnum (Ascii x1 x2 x3 x4 x5 x6 x7 false))::os) 157 | ((Ascii x1 x2 x3 x4 x5 x6 x7 false)::bs). 158 | Proof with auto. 159 | unfold DeserializeCorrect. 160 | intros. 161 | inversion H0. 162 | apply H in H2. 163 | rewrite <- H2. 164 | destruct x1,x2,x3,x4,x5,x6,x7; reflexivity. 165 | Qed. 166 | 167 | Lemma correct_nfixnum: forall os bs x1 x2 x3 x4 x5, 168 | DeserializeCorrect os bs -> 169 | DeserializeCorrect 170 | ((NFixnum (Ascii x1 x2 x3 x4 x5 true true true))::os) 171 | ((Ascii x1 x2 x3 x4 x5 true true true)::bs). 172 | Proof with auto. 173 | unfold DeserializeCorrect. 174 | intros. 175 | inversion H0. 176 | apply H in H2. 177 | rewrite <- H2. 178 | destruct x1,x2,x3,x4,x5; reflexivity. 179 | Qed. 180 | 181 | Lemma correct_uint8 : forall os bs c, 182 | DeserializeCorrect os bs -> 183 | DeserializeCorrect ((Uint8 c)::os) ("204"::list_of_ascii8 c ++ bs). 184 | Proof with auto. 185 | unfold DeserializeCorrect. 186 | intros. 187 | inversion H0. 188 | apply H in H2. 189 | rewrite <- H2... 190 | Qed. 191 | 192 | Lemma correct_uint16 : forall os bs c, 193 | DeserializeCorrect os bs -> 194 | DeserializeCorrect ((Uint16 c)::os) ("205"::list_of_ascii16 c ++ bs). 195 | Proof with auto. 196 | unfold DeserializeCorrect. 197 | intros. 198 | destruct c. 199 | inversion H0. 200 | apply H in H2. 201 | rewrite <- H2... 202 | Qed. 203 | 204 | Lemma correct_uint32 : forall os bs c, 205 | DeserializeCorrect os bs -> 206 | DeserializeCorrect ((Uint32 c)::os) ("206"::list_of_ascii32 c ++ bs). 207 | Proof with auto. 208 | unfold DeserializeCorrect. 209 | intros. 210 | destruct c. 211 | destruct a, a0. 212 | inversion H0. 213 | apply H in H2. 214 | rewrite <- H2... 215 | Qed. 216 | 217 | Lemma correct_uint64 : forall os bs c, 218 | DeserializeCorrect os bs -> 219 | DeserializeCorrect ((Uint64 c)::os) ("207"::list_of_ascii64 c ++ bs). 220 | Proof with auto. 221 | unfold DeserializeCorrect. 222 | intros. 223 | destruct c. 224 | destruct a, a0. 225 | destruct a, a0, a1, a2. 226 | inversion H0. 227 | apply H in H2. 228 | rewrite <- H2... 229 | Qed. 230 | 231 | Lemma correct_int8 : forall os bs c, 232 | DeserializeCorrect os bs -> 233 | DeserializeCorrect ((Int8 c)::os) ("208"::list_of_ascii8 c ++ bs). 234 | Proof with auto. 235 | unfold DeserializeCorrect. 236 | intros. 237 | inversion H0. 238 | apply H in H2. 239 | rewrite <- H2... 240 | Qed. 241 | 242 | Lemma correct_int16 : forall os bs c, 243 | DeserializeCorrect os bs -> 244 | DeserializeCorrect ((Int16 c)::os) ("209"::list_of_ascii16 c ++ bs). 245 | Proof with auto. 246 | unfold DeserializeCorrect. 247 | intros. 248 | destruct c. 249 | inversion H0. 250 | apply H in H2. 251 | rewrite <- H2... 252 | Qed. 253 | 254 | Lemma correct_int32 : forall os bs c, 255 | DeserializeCorrect os bs -> 256 | DeserializeCorrect ((Int32 c)::os) ("210"::list_of_ascii32 c ++ bs). 257 | Proof with auto. 258 | unfold DeserializeCorrect. 259 | intros. 260 | destruct c. 261 | destruct a, a0. 262 | inversion H0. 263 | apply H in H2. 264 | rewrite <- H2... 265 | Qed. 266 | 267 | Lemma correct_int64 : forall os bs c, 268 | DeserializeCorrect os bs -> 269 | DeserializeCorrect ((Int64 c)::os) ("211"::list_of_ascii64 c ++ bs). 270 | Proof. 271 | unfold DeserializeCorrect. 272 | intros. 273 | destruct c. 274 | destruct a, a0. 275 | destruct a, a0, a1, a2. 276 | inversion H0. 277 | apply H in H2. 278 | rewrite <- H2. 279 | reflexivity. 280 | Qed. 281 | 282 | Lemma correct_float : forall os bs c, 283 | DeserializeCorrect os bs -> 284 | DeserializeCorrect ((Float c)::os) ("202"::list_of_ascii32 c ++ bs). 285 | Proof. 286 | unfold DeserializeCorrect. 287 | intros. 288 | destruct c. 289 | destruct a, a0. 290 | inversion H0. 291 | apply H in H2. 292 | rewrite <- H2. 293 | reflexivity. 294 | Qed. 295 | 296 | Lemma correct_double : forall os bs c, 297 | DeserializeCorrect os bs -> 298 | DeserializeCorrect ((Double c)::os) ("203"::list_of_ascii64 c ++ bs). 299 | Proof. 300 | unfold DeserializeCorrect. 301 | intros. 302 | destruct c. 303 | destruct a, a0. 304 | destruct a, a0, a1, a2. 305 | inversion H0. 306 | apply H in H2. 307 | rewrite <- H2. 308 | reflexivity. 309 | Qed. 310 | 311 | Lemma deserialize_take_length: forall xs ys, 312 | take (List.length xs) (deserialize (List.length xs) (xs ++ ys)) = List.map (fun x => FixRaw [ x ]) xs. 313 | Proof with auto. 314 | induction xs; [ reflexivity | intros ]. 315 | simpl. 316 | rewrite IHxs... 317 | Qed. 318 | 319 | Lemma deserialize_drop_length: forall xs ys, 320 | drop (List.length xs) (deserialize (List.length xs) (xs ++ ys)) = deserialize 0 ys. 321 | Proof with auto. 322 | induction xs; [ reflexivity | intros ]. 323 | simpl. 324 | rewrite IHxs... 325 | Qed. 326 | 327 | Lemma compact_eq : forall xs, 328 | compact (List.map (fun x => FixRaw [ x ]) xs) = xs. 329 | Proof with auto. 330 | intros. 331 | unfold compact. 332 | rewrite map_tailrec_equiv. 333 | induction xs; [ reflexivity | intros ]. 334 | simpl. 335 | rewrite IHxs... 336 | Qed. 337 | 338 | Lemma correct_fixraw: forall os bs cs b1 b2 b3 b4 b5, 339 | DeserializeCorrect os bs -> 340 | Ascii b1 b2 b3 b4 b5 false false false = ascii8_of_nat (List.length cs) -> 341 | List.length cs < pow 5 -> 342 | DeserializeCorrect (FixRaw cs :: os) ((Ascii b1 b2 b3 b4 b5 true false true) :: cs ++ bs). 343 | Proof with auto. 344 | unfold DeserializeCorrect. 345 | intros. 346 | inversion H2. 347 | assert (bs0 = bs); [| rewrite_for bs0 ]. 348 | apply app_same in H11... 349 | apply H in H13. 350 | assert (length cs < pow 8). 351 | transitivity (pow 5); auto. 352 | apply pow_lt... 353 | destruct b1,b2,b3,b4,b5; 354 | ((replace (deserialize 0 _ ) with 355 | (let n := nat_of_ascii8 (ascii8_of_nat (length cs)) in 356 | let (zs, ws) := split_at n @@ deserialize n (cs++bs) in 357 | FixRaw (compact zs) :: ws)); 358 | [ unfold split_at; 359 | rewrite nat_ascii8_embedding, deserialize_take_length, deserialize_drop_length, compact_eq, <- H13 360 | | rewrite <- H7])... 361 | Qed. 362 | 363 | Lemma correct_raw16: forall os bs cs s1 s2, 364 | DeserializeCorrect os bs -> 365 | (s1, s2) = ascii16_of_nat (List.length cs) -> 366 | List.length cs < pow 16 -> 367 | DeserializeCorrect (Raw16 cs :: os) ("218" :: s1 :: s2 :: cs ++ bs). 368 | Proof with auto. 369 | unfold DeserializeCorrect. 370 | intros. 371 | inversion H2. 372 | assert (bs0 = bs); [| rewrite_for bs0 ]. 373 | apply app_same in H8... 374 | apply H in H10. 375 | change (deserialize 0 _ ) with 376 | (let (zs, ws) := 377 | split_at (nat_of_ascii16 (s1,s2)) @@ deserialize (nat_of_ascii16 (s1,s2)) (cs++bs) in 378 | Raw16 (compact zs) :: ws). 379 | unfold split_at. 380 | rewrite H7, nat_ascii16_embedding, deserialize_take_length, deserialize_drop_length, compact_eq, H10... 381 | Qed. 382 | 383 | Lemma correct_raw32: forall os bs cs s1 s2 s3 s4, 384 | DeserializeCorrect os bs -> 385 | ((s1, s2), (s3, s4)) = ascii32_of_nat (List.length cs) -> 386 | List.length cs < pow 32 -> 387 | DeserializeCorrect (Raw32 cs :: os) ("219" :: s1 :: s2 :: s3 :: s4 :: cs ++ bs). 388 | Proof with auto. 389 | unfold DeserializeCorrect. 390 | intros. 391 | inversion H2. 392 | assert (bs0 = bs); [| rewrite_for bs0 ]. 393 | apply app_same in H10... 394 | apply H in H12. 395 | change (deserialize 0 _ ) with 396 | (let (zs, ws) := 397 | split_at (nat_of_ascii32 ((s1,s2),(s3,s4))) @@ deserialize (nat_of_ascii32 ((s1,s2),(s3,s4))) (cs++bs) in 398 | Raw32 (compact zs) :: ws). 399 | unfold split_at. 400 | rewrite H7, nat_ascii32_embedding, deserialize_take_length, deserialize_drop_length, compact_eq, H12... 401 | Qed. 402 | 403 | Lemma correct_fixarray : forall os bs n xs ys b1 b2 b3 b4, 404 | DeserializeCorrect os bs -> 405 | (xs, ys) = split_at n os -> 406 | n < pow 4 -> 407 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat n -> 408 | DeserializeCorrect (FixArray xs :: ys) (Ascii b1 b2 b3 b4 true false false true :: bs). 409 | Proof with auto. 410 | unfold DeserializeCorrect. 411 | intros. 412 | inversion H3. 413 | assert (os = os0); [| rewrite_for os0 ]. 414 | apply split_at_soundness in H0. 415 | apply split_at_soundness in H12. 416 | rewrite H0, H12... 417 | apply H in H9. 418 | assert (n0 < pow 8). 419 | transitivity (pow 4); auto. 420 | apply pow_lt... 421 | destruct b1, b2, b3, b4; 422 | (replace (deserialize 0 (_ :: bs)) with 423 | (let (zs, ws) := 424 | split_at (nat_of_ascii8 (ascii8_of_nat n0)) @@ deserialize 0 bs 425 | in 426 | FixArray zs :: ws); 427 | [ rewrite H9, nat_ascii8_embedding, <- H12 | rewrite <- H14])... 428 | Qed. 429 | 430 | Lemma correct_array16 : forall os bs n xs ys s1 s2 , 431 | DeserializeCorrect os bs -> 432 | n < pow 16 -> 433 | (s1, s2) = ascii16_of_nat n -> 434 | (xs, ys) = split_at n os -> 435 | DeserializeCorrect (Array16 xs :: ys) ("220" :: s1 :: s2 :: bs). 436 | Proof with auto. 437 | unfold DeserializeCorrect. 438 | intros. 439 | inversion H3. 440 | assert (os = os0). 441 | apply split_at_soundness in H2. 442 | apply split_at_soundness in H10. 443 | rewrite H2, H10... 444 | 445 | rewrite_for os0. 446 | apply H in H9. 447 | assert ( n = nat_of_ascii16 (s1, s2)). 448 | rewrite H1. 449 | rewrite nat_ascii16_embedding... 450 | 451 | simpl. 452 | change (nat_of_ascii8 s1 * 256 + nat_of_ascii8 s2) with (nat_of_ascii16 (s1, s2)). 453 | rewrite <- H13. 454 | inversion H2. 455 | rewrite <- H9... 456 | Qed. 457 | 458 | Lemma correct_array32: forall os bs n xs ys s1 s2 s3 s4, 459 | DeserializeCorrect os bs -> 460 | (xs, ys) = split_at n os -> 461 | n < pow 32 -> 462 | ((s1, s2), (s3, s4)) = ascii32_of_nat n -> 463 | DeserializeCorrect (Array32 xs :: ys) ("221" :: s1 :: s2 :: s3 :: s4 :: bs). 464 | Proof with auto. 465 | unfold DeserializeCorrect. 466 | intros. 467 | inversion H3. 468 | assert (os = os0). 469 | apply split_at_soundness in H0. 470 | apply split_at_soundness in H12. 471 | rewrite H0, H12... 472 | 473 | rewrite_for os0. 474 | apply H in H9. 475 | change (deserialize 0 ("221" :: s1 :: s2 :: s3 :: s4 :: bs)) with 476 | (let (zs, ws) := split_at (nat_of_ascii32 (s1, s2, (s3, s4))) (deserialize 0 bs) in 477 | Array32 zs :: ws). 478 | rewrite H9, H14, nat_ascii32_embedding, <- H12... 479 | Qed. 480 | 481 | Lemma correct_fixmap: forall os bs n xs ys b1 b2 b3 b4, 482 | DeserializeCorrect os bs -> 483 | (xs, ys) = split_at (2 * n) os -> 484 | length xs = 2 * n -> 485 | n < pow 4 -> 486 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat n -> 487 | DeserializeCorrect (FixMap (pair xs) :: ys) (Ascii b1 b2 b3 b4 false false false true :: bs). 488 | Proof with auto. 489 | unfold DeserializeCorrect. 490 | intros. 491 | inversion H4. 492 | assert ( n < pow 8). 493 | transitivity (pow 4); auto. 494 | apply pow_lt... 495 | assert ( n0 < pow 8). 496 | transitivity (pow 4); auto. 497 | apply pow_lt... 498 | assert (n0 = n); [| rewrite_for n0 ]. 499 | rewrite H3 in H16. 500 | apply ascii8_of_nat_eq in H16... 501 | assert (xs0 = xs); [| rewrite_for xs0 ]. 502 | rewrite <- (unpair_pair _ n xs), <- (unpair_pair _ n xs0); auto. 503 | rewrite H5... 504 | assert (os0 = os); [| rewrite_for os0 ]. 505 | apply split_at_soundness in H0. 506 | apply split_at_soundness in H13. 507 | rewrite H0, H13... 508 | apply H in H11. 509 | destruct b1, b2, b3, b4; 510 | (replace (deserialize 0 (_ :: bs)) with 511 | (let (zs, ws) := 512 | split_at (2 * (nat_of_ascii8 (ascii8_of_nat n))) @@ deserialize 0 bs 513 | in 514 | FixMap (pair zs) :: ws); 515 | [ rewrite nat_ascii8_embedding, H11, <- H13 516 | | rewrite <- H16 ])... 517 | Qed. 518 | 519 | Lemma correct_map16: forall os bs n xs ys s1 s2, 520 | DeserializeCorrect os bs -> 521 | (xs, ys) = split_at (2 * n) os -> 522 | length xs = 2 * n -> 523 | n < pow 16 -> 524 | (s1, s2) = ascii16_of_nat n -> 525 | DeserializeCorrect (Map16 (pair xs) :: ys) ("222" :: s1 :: s2 :: bs). 526 | Proof with auto. 527 | unfold DeserializeCorrect. 528 | intros. 529 | inversion H4. 530 | assert (n0 = n). 531 | rewrite H3 in H14. 532 | apply ascii16_of_nat_eq in H14... 533 | rewrite_for n0. 534 | assert (xs0 = xs). 535 | rewrite <- (unpair_pair _ n xs), <- (unpair_pair _ n xs0); auto. 536 | rewrite H5... 537 | rewrite_for xs0. 538 | assert (os0 = os). 539 | apply split_at_soundness in H0. 540 | apply split_at_soundness in H11. 541 | rewrite H0, H11... 542 | rewrite_for os0. 543 | apply H in H10. 544 | change (deserialize 0 ("222" :: s1 :: s2 :: bs)) with 545 | (let (zs, ws) := split_at (2 * nat_of_ascii16 (s1, s2)) @@ deserialize 0 bs in 546 | Map16 (pair zs) :: ws). 547 | rewrite H10, H14, nat_ascii16_embedding, <- H11... 548 | Qed. 549 | 550 | Lemma correct_map32: forall os bs n xs ys s1 s2 s3 s4, 551 | DeserializeCorrect os bs -> 552 | (xs, ys) = split_at (2 * n) os -> 553 | length xs = 2 * n -> 554 | n < pow 32 -> 555 | ((s1, s2), (s3, s4)) = ascii32_of_nat n -> 556 | DeserializeCorrect (Map32 (pair xs) :: ys) ("223" :: s1 :: s2 :: s3 :: s4 :: bs). 557 | Proof with auto. 558 | unfold DeserializeCorrect. 559 | intros. 560 | inversion H4. 561 | assert (n0 = n); [| rewrite_for n0 ]. 562 | rewrite H3 in H16. 563 | apply ascii32_of_nat_eq in H16... 564 | assert (xs0 = xs); [| rewrite_for xs0 ]. 565 | rewrite <- (unpair_pair _ n xs), <- (unpair_pair _ n xs0); auto. 566 | rewrite H5... 567 | assert (os0 = os); [| rewrite_for os0 ]. 568 | apply split_at_soundness in H0. 569 | apply split_at_soundness in H13. 570 | rewrite H0, H13... 571 | apply H in H11. 572 | change (deserialize 0 ("223" :: s1 :: s2 :: s3 :: s4 :: bs)) with 573 | (let (zs, ws) := split_at (2 * nat_of_ascii32 ((s1, s2),(s3,s4))) @@ deserialize 0 bs in 574 | Map32 (pair zs) :: ws). 575 | rewrite H16, H11, nat_ascii32_embedding, <- H13... 576 | Qed. 577 | 578 | Lemma correct_intro : forall os bs, 579 | (SerializedList os bs -> DeserializeCorrect os bs) -> 580 | DeserializeCorrect os bs. 581 | Proof with auto. 582 | unfold DeserializeCorrect. 583 | intros. 584 | apply H in H0... 585 | Qed. 586 | 587 | Theorem deserialize_correct : forall os bs, 588 | DeserializeCorrect os bs. 589 | Proof with auto. 590 | intros. 591 | apply correct_intro. 592 | intros. 593 | pattern os, bs. 594 | apply SerializedList_ind; intros; auto. 595 | apply correct_bot... 596 | apply correct_nil... 597 | apply correct_true... 598 | apply correct_false... 599 | apply correct_pfixnum... 600 | apply correct_nfixnum... 601 | apply correct_uint8... 602 | apply correct_uint16... 603 | apply correct_uint32... 604 | apply correct_uint64... 605 | apply correct_int8... 606 | apply correct_int16... 607 | apply correct_int32... 608 | apply correct_int64... 609 | apply correct_float... 610 | apply correct_double... 611 | apply correct_fixraw... 612 | simpl; apply correct_raw16... 613 | simpl; apply correct_raw32... 614 | apply correct_fixarray with (os:=os0) (n:=n)... 615 | apply correct_array16 with (os:=os0) (n:=n)... 616 | apply correct_array32 with (os:=os0) (n:=n)... 617 | apply correct_fixmap with (os:=os0) (n:=n)... 618 | apply correct_map16 with (os:=os0) (n:=n)... 619 | apply correct_map32 with (os:=os0) (n:=n)... 620 | Qed. 621 | 622 | Lemma app_nil: forall A (xs : list A), 623 | xs ++ [] = xs. 624 | Proof. 625 | induction xs. 626 | reflexivity. 627 | simpl. 628 | rewrite IHxs. 629 | reflexivity. 630 | Qed. 631 | 632 | -------------------------------------------------------------------------------- /proof/ExtractUtil.v: -------------------------------------------------------------------------------- 1 | Require Ascii. 2 | Require String. 3 | Require List. 4 | 5 | 6 | (* basic types for OCaml *) 7 | Parameter mlunit mlchar mlint mlstring : Set. 8 | 9 | (* unit *) 10 | Extract Constant mlunit => "unit". 11 | 12 | (* bool *) 13 | Extract Inductive bool => "bool" ["true" "false"]. 14 | Extract Inductive sumbool => "bool" ["true" "false"]. 15 | 16 | (* int *) 17 | Extract Constant mlint => "int". 18 | Parameter mlint_of_nat : nat -> mlint. 19 | Parameter nat_of_mlint : mlint -> nat. 20 | Extract Constant mlint_of_nat => 21 | "let rec iter = function O -> 0 | S p -> succ (iter p) in iter". 22 | Extract Constant nat_of_mlint => 23 | "let rec iter = function 0 -> O | n -> S (iter (pred n)) in iter". 24 | 25 | (* char *) 26 | Extract Constant mlchar => "char". 27 | Parameter mlchar_of_mlint : mlint -> mlchar. 28 | Parameter mlint_of_mlchar : mlchar -> mlint. 29 | Extract Constant mlchar_of_mlint => "char_of_int". 30 | Extract Constant mlint_of_mlchar => "int_of_char". 31 | 32 | (* list *) 33 | Extract Inductive list => "list" ["[]" "(::)"]. 34 | 35 | (* option *) 36 | Extract Inductive option => "option" ["None" "Some"]. 37 | 38 | (* string *) 39 | Extract Constant mlstring => "string". 40 | Extract Inductive String.string => "ascii list" ["[]" "(::)"]. 41 | Parameter string_of_list : List.list Ascii.ascii -> String.string. 42 | Parameter list_of_string : String.string -> List.list Ascii.ascii. 43 | Extract Constant list_of_string => "(fun x -> x)". 44 | Extract Constant string_of_list => "(fun x -> x)". 45 | 46 | Parameter mlstring_of_list : forall {A:Type}, 47 | (A->mlchar) -> List.list A -> mlstring. 48 | Parameter list_of_mlstring : forall {A:Type}, 49 | (mlchar->A) -> mlstring -> List.list A. 50 | Extract Constant mlstring_of_list => 51 | "(fun f s -> String.concat """" 52 | (List.map (fun x -> String.make 1 (f x)) s))". 53 | Extract Constant list_of_mlstring => " 54 | (fun f s -> 55 | let rec explode_rec n = 56 | if n >= String.length s then 57 | [] 58 | else 59 | f (String.get s n) :: explode_rec (succ n) 60 | in 61 | explode_rec 0) 62 | ". 63 | 64 | Parameter mlstring_of_mlint : mlint -> mlstring. 65 | Extract Constant mlstring_of_mlint => "string_of_int". 66 | 67 | 68 | (* print to stdout *) 69 | Parameter print_mlstring : mlstring -> mlunit. 70 | Parameter println_mlstring : mlstring -> mlunit. 71 | Parameter prerr_mlstring : mlstring -> mlunit. 72 | Parameter prerrln_mlstring : mlstring -> mlunit. 73 | Parameter semicolon_flipped : forall {A:Type}, A -> mlunit -> A. 74 | Extract Constant semicolon_flipped => "(fun x f -> f; x)". 75 | Extract Constant print_mlstring => "print_string". 76 | Extract Constant println_mlstring => "print_endline". 77 | Extract Constant prerr_mlstring => "print_string". 78 | Extract Constant prerrln_mlstring => "print_endline". 79 | 80 | CoInductive llist (A: Type) : Type := 81 | LNil | LCons (x: A) (xs: llist A). 82 | 83 | Implicit Arguments LNil [A]. 84 | Implicit Arguments LCons [A]. 85 | 86 | Parameter get_contents_mlchars : llist mlchar. 87 | Extract Constant get_contents_mlchars => " 88 | let rec iter store = 89 | lazy 90 | begin 91 | try (LCons (input_char stdin, iter())) with 92 | | End_of_file -> LNil 93 | end 94 | in 95 | iter ()". 96 | -------------------------------------------------------------------------------- /proof/ListUtil.v: -------------------------------------------------------------------------------- 1 | Require Import List Omega. 2 | 3 | Notation "[ ]" := nil : list_scope. 4 | Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) : list_scope. 5 | 6 | Definition length_tailrec {A} (xs:list A) := 7 | fold_left (fun x _ => S x) xs 0. 8 | 9 | Lemma length_tailrec_equiv: forall A (xs: list A), 10 | length_tailrec xs = length xs. 11 | Proof. 12 | exact fold_left_length. 13 | Qed. 14 | 15 | Definition rev_tailrec {A} (xs: list A) := List.rev' xs. 16 | 17 | Lemma rev_tailrec_equiv: forall A (xs: list A), 18 | rev_tailrec xs = rev xs. 19 | Proof. 20 | intros. 21 | rewrite rev_alt. 22 | reflexivity. 23 | Qed. 24 | 25 | Definition map_tailrec {A B} (f: A -> B) (xs: list A) := 26 | rev_tailrec (fold_left (fun acc x => f x :: acc) xs []). 27 | 28 | Lemma map_tailrec_equiv: forall A B (f: A -> B) (xs: list A), 29 | map_tailrec f xs = map f xs. 30 | Proof. 31 | intros. 32 | unfold map_tailrec. 33 | rewrite rev_tailrec_equiv. 34 | set (body := fun acc x => f x :: acc). 35 | assert (Hlemma: forall xs ys zs, fold_left body xs (ys ++ zs) = fold_left body xs ys ++ zs). 36 | { clear. 37 | intros xs. 38 | induction xs; [reflexivity|]. 39 | intros. 40 | simpl. 41 | rewrite <-IHxs. 42 | reflexivity. 43 | } 44 | induction xs; [reflexivity|]. 45 | simpl. 46 | rewrite <-IHxs. 47 | rewrite <-rev_unit. 48 | rewrite <-Hlemma. 49 | reflexivity. 50 | Qed. 51 | 52 | Lemma rev_append_app_left: forall A (xs ys zs: list A), 53 | rev_append (ys ++ xs) zs = rev_append xs (rev_append ys zs). 54 | Proof. 55 | intros. 56 | rewrite !rev_append_rev. 57 | rewrite rev_app_distr. 58 | rewrite app_assoc. 59 | reflexivity. 60 | Qed. 61 | 62 | Lemma app_same : forall A (xs ys zs : list A), 63 | xs ++ ys = xs ++ zs -> ys = zs. 64 | Proof. 65 | induction xs; intros; simpl in H. 66 | auto. 67 | 68 | inversion H. 69 | apply IHxs in H1. 70 | auto. 71 | Qed. 72 | Lemma length_lt_O: forall A (x : A) xs, 73 | length (x::xs) > 0. 74 | Proof. 75 | intros. 76 | simpl. 77 | omega. 78 | Qed. 79 | 80 | Lemma length_inv: forall A (x y : A) xs ys, 81 | length (x :: xs) = length (y :: ys) -> 82 | length xs = length ys. 83 | Proof. 84 | intros. 85 | inversion H. 86 | auto. 87 | Qed. 88 | 89 | Hint Resolve length_lt_O. 90 | 91 | 92 | Fixpoint take {A} n (xs : list A) := 93 | match n, xs with 94 | | O , _ => [] 95 | | _ , [] => [] 96 | | S m, x::xs => 97 | x::take m xs 98 | end. 99 | 100 | Fixpoint drop {A} n (xs : list A) := 101 | match n, xs with 102 | | O , _ => xs 103 | | _ , [] => [] 104 | | S m, x::xs => 105 | drop m xs 106 | end. 107 | 108 | Definition split_at {A} (n : nat) (xs : list A) : list A * list A := 109 | (take n xs, drop n xs). 110 | 111 | Lemma take_length : forall A ( xs ys : list A) n, 112 | n = List.length xs -> 113 | take n (xs ++ ys) = xs. 114 | Proof. 115 | induction xs; intros; simpl in *. 116 | rewrite H. 117 | reflexivity. 118 | 119 | rewrite H. 120 | simpl. 121 | rewrite IHxs; auto. 122 | Qed. 123 | 124 | Lemma drop_length : forall A ( xs ys : list A) n, 125 | n = List.length xs -> 126 | drop n (xs ++ ys) = ys. 127 | Proof. 128 | induction xs; intros; simpl in *. 129 | rewrite H. 130 | reflexivity. 131 | 132 | rewrite H. 133 | simpl. 134 | rewrite IHxs; auto. 135 | Qed. 136 | 137 | Lemma split_at_length : forall A (xs ys : list A), 138 | (xs, ys) = split_at (length xs) (xs ++ ys). 139 | Proof. 140 | intros. 141 | unfold split_at. 142 | rewrite take_length, drop_length; auto. 143 | Qed. 144 | 145 | Lemma take_length_lt : forall A (xs ys : list A) n, 146 | ys = take n xs -> 147 | List.length ys <= n. 148 | Proof. 149 | induction xs; intros. 150 | rewrite H. 151 | destruct n; simpl; omega... 152 | 153 | destruct n. 154 | rewrite H. 155 | simpl. 156 | auto... 157 | 158 | destruct ys; [ discriminate |]. 159 | inversion H. 160 | rewrite <- H2. 161 | apply IHxs in H2. 162 | simpl. 163 | omega... 164 | Qed. 165 | 166 | Lemma split_at_length_lt : forall A (xs ys zs : list A) n, 167 | (xs, ys) = split_at n zs -> 168 | List.length xs <= n. 169 | Proof. 170 | intros. 171 | unfold split_at in *. 172 | inversion H. 173 | apply (take_length_lt _ zs). 174 | reflexivity. 175 | Qed. 176 | 177 | Lemma split_at_soundness : forall A (xs ys zs : list A) n, 178 | (ys,zs) = split_at n xs -> 179 | xs = ys ++ zs. 180 | Proof. 181 | induction xs; induction n; intros; simpl; 182 | try (inversion H; reflexivity). 183 | 184 | unfold split_at in *. 185 | simpl in H. 186 | destruct ys. 187 | inversion H. 188 | 189 | rewrite (IHxs ys zs n); auto. 190 | inversion H. 191 | reflexivity. 192 | 193 | inversion H. 194 | reflexivity. 195 | Qed. 196 | 197 | Lemma take_nil : forall A n, 198 | take n ([] : list A) = []. 199 | Proof. 200 | induction n; auto. 201 | Qed. 202 | 203 | Lemma take_drop_length : forall A ( xs ys : list A) n, 204 | take n xs = ys -> 205 | drop n xs = [ ] -> 206 | xs = ys. 207 | Proof. 208 | induction xs; intros; simpl in *. 209 | rewrite take_nil in H. 210 | assumption. 211 | 212 | destruct n. 213 | simpl in H0. 214 | discriminate. 215 | 216 | simpl in *. 217 | destruct ys. 218 | discriminate. 219 | 220 | inversion H. 221 | rewrite H3. 222 | apply IHxs in H3; auto. 223 | rewrite H3. 224 | reflexivity. 225 | Qed. 226 | 227 | Fixpoint pair { A } ( xs : list A ) := 228 | match xs with 229 | | [] => [] 230 | | [x] => [] 231 | | k :: v :: ys => 232 | (k, v) :: pair ys 233 | end. 234 | 235 | Definition unpair {A} (xs : list (A * A)) := 236 | flat_map (fun x => [ fst x; snd x]) xs. 237 | 238 | Lemma pair_unpair : forall A ( xs : list ( A * A )), 239 | pair (unpair xs) = xs. 240 | Proof. 241 | induction xs; intros; simpl; auto. 242 | rewrite IHxs. 243 | destruct a. 244 | simpl. 245 | reflexivity. 246 | Qed. 247 | 248 | Lemma unpair_pair : forall A n ( xs : list A), 249 | List.length xs = 2 * n -> 250 | unpair (pair xs) = xs. 251 | Proof. 252 | induction n; intros. 253 | destruct xs; auto. 254 | simpl in H. 255 | discriminate. 256 | 257 | destruct xs. 258 | simpl in H. 259 | discriminate... 260 | 261 | destruct xs. 262 | simpl in H. 263 | assert (1 <> S (n + S (n + 0))); [ omega | contradiction ]... 264 | 265 | replace (2 * S n) with (2 + 2 * n) in H; [| omega ]. 266 | simpl in *. 267 | inversion H. 268 | apply IHn in H1. 269 | rewrite H1. 270 | reflexivity. 271 | Qed. 272 | 273 | Lemma pair_length' : forall A n (xs : list A), 274 | n = List.length (pair xs) -> 275 | 2 * n <= List.length xs. 276 | Proof. 277 | induction n; intros; simpl. 278 | omega... 279 | 280 | destruct xs; simpl in *; [ discriminate |]. 281 | destruct xs; simpl in *; [ discriminate |]. 282 | inversion H. 283 | apply IHn in H1. 284 | omega. 285 | Qed. 286 | 287 | 288 | Lemma pair_length : forall A (xs : list A), 289 | 2 * List.length (pair xs) <= List.length xs. 290 | Proof. 291 | intros. 292 | apply pair_length'. 293 | reflexivity. 294 | Qed. 295 | 296 | Lemma unpair_length : forall A ( xs : list (A * A)), 297 | List.length (unpair xs) = 2 * List.length xs. 298 | Proof. 299 | induction xs; simpl; auto. 300 | rewrite IHxs. 301 | omega. 302 | Qed. 303 | 304 | Lemma unpair_split_at: forall A (x1 x2 : A) xs ys, 305 | (unpair ((x1, x2) :: xs), ys) = 306 | split_at (2 * length ((x1, x2) :: xs)) (x1 :: x2 :: unpair xs ++ ys). 307 | Proof. 308 | intros. 309 | replace (2 * (length ((x1,x2) :: xs))) with (length (unpair ((x1,x2)::xs))). 310 | apply split_at_length. 311 | 312 | simpl. 313 | rewrite unpair_length. 314 | omega. 315 | Qed. 316 | 317 | (* Class of functions that prepend something to their argument. These 318 | * will typically be tail-recursive functions that maintain an 319 | * accumulator. *) 320 | Definition Prepending {A} (f: list A -> list A) := forall ys zs, 321 | f (ys ++ zs) = f ys ++ zs. 322 | 323 | Lemma Prepending_nil: forall {A} f, Prepending f -> forall (zs: list A), 324 | f zs = f [] ++ zs. 325 | Proof. 326 | unfold Prepending. intros * H *. apply (H [] zs). 327 | Qed. 328 | 329 | Lemma Prepending_rev_append: forall A (xs: list A), 330 | Prepending (rev_append xs). 331 | Proof. 332 | unfold Prepending. 333 | intros. 334 | rewrite !rev_append_rev. 335 | rewrite app_assoc. 336 | reflexivity. 337 | Qed. 338 | -------------------------------------------------------------------------------- /proof/Main.v: -------------------------------------------------------------------------------- 1 | Require Import ExtrOcamlBasic ExtrOcamlIntConv ExtrOcamlNatInt. 2 | Require Import SerializeImplement DeserializeImplement. 3 | Extraction "msgpackCore.ml" serialize_rev deserialize. 4 | -------------------------------------------------------------------------------- /proof/Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## v # The Coq Proof Assistant ## 3 | ## "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) 225 | 226 | %.v.beautified: 227 | $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* 228 | 229 | # WARNING 230 | # 231 | # This Makefile has been automagically generated 232 | # Edit at your own risks ! 233 | # 234 | # END OF WARNING 235 | 236 | -------------------------------------------------------------------------------- /proof/MultiByte.v: -------------------------------------------------------------------------------- 1 | (* 2 | 16bits,32bits,64bitsの定義。BigEndian。 3 | *) 4 | Require Import List Ascii NArith Omega Euclid. 5 | Require Import Pow. 6 | 7 | Open Scope char_scope. 8 | 9 | (* * 型の定義 *) 10 | Definition ascii8 : Set := ascii. 11 | Definition ascii16 : Set := (ascii8 * ascii8)%type. 12 | Definition ascii32 : Set := (ascii16 * ascii16)%type. 13 | Definition ascii64 : Set := (ascii32 * ascii32)%type. 14 | 15 | (** ** natとの相互変換 *) 16 | Definition nat_of_ascii8 := 17 | nat_of_ascii. 18 | 19 | Definition ascii8_of_nat := 20 | ascii_of_nat. 21 | 22 | Definition ascii16_of_nat (a : nat) := 23 | let (q,r,_,_) := divmod a (pow 8) (pow_lt_O 8) in 24 | (ascii8_of_nat q, ascii8_of_nat r). 25 | 26 | Definition nat_of_ascii16 (a : ascii16) := 27 | let (a1, a2) := a in 28 | (nat_of_ascii8 a1) * (pow 8) + (nat_of_ascii8 a2). 29 | 30 | Definition ascii32_of_nat (a : nat) := 31 | let (q,r,_,_) := divmod a (pow 16) (pow_lt_O 16) in 32 | (ascii16_of_nat q, ascii16_of_nat r). 33 | 34 | Definition nat_of_ascii32 (a : ascii32) := 35 | let (a1, a2) := a in 36 | (nat_of_ascii16 a1) * (pow 16) + (nat_of_ascii16 a2). 37 | 38 | Definition ascii64_of_nat (a : nat) := 39 | let (q,r,_,_) := divmod a (pow 32) (pow_lt_O 32) in 40 | (ascii32_of_nat q, ascii32_of_nat r). 41 | 42 | Definition nat_of_ascii64 (a : ascii64) := 43 | let (a1, a2) := a in 44 | (nat_of_ascii32 a1) * (pow 32) + (nat_of_ascii32 a2). 45 | 46 | (** ** natに戻せることの証明 *) 47 | Lemma nat_ascii8_embedding : forall n, 48 | n < pow 8 -> 49 | nat_of_ascii8 (ascii8_of_nat n) = n. 50 | Proof. 51 | intros. 52 | unfold nat_of_ascii8,ascii8_of_nat. 53 | rewrite nat_ascii_embedding. 54 | reflexivity. 55 | 56 | simpl in H. 57 | assumption. 58 | Qed. 59 | 60 | Lemma nat_ascii16_embedding : forall n, 61 | n < pow 16 -> 62 | nat_of_ascii16 (ascii16_of_nat n) = n. 63 | Proof. 64 | intros. 65 | unfold ascii16_of_nat, nat_of_ascii16. 66 | destruct divmod. 67 | rewrite (nat_ascii8_embedding q), (nat_ascii8_embedding r); try omega. 68 | apply divmod_lt_q with (t := 8) in e; 69 | change (8+8) with 16; assumption. 70 | Qed. 71 | 72 | Lemma nat_ascii32_embedding : forall n, 73 | n < pow 32 -> 74 | nat_of_ascii32 (ascii32_of_nat n) = n. 75 | Proof. 76 | intros. 77 | unfold ascii32_of_nat, nat_of_ascii32. 78 | destruct divmod. 79 | rewrite (nat_ascii16_embedding q), (nat_ascii16_embedding r); try omega. 80 | apply divmod_lt_q with (t := 16) in e; 81 | change (16+16) with 32; assumption. 82 | Qed. 83 | 84 | Lemma nat_ascii64_embedding : forall n, 85 | n < pow 64 -> 86 | nat_of_ascii64 (ascii64_of_nat n) = n. 87 | Proof. 88 | intros. 89 | unfold ascii64_of_nat, nat_of_ascii64. 90 | destruct divmod. 91 | rewrite (nat_ascii32_embedding q), (nat_ascii32_embedding r); try omega. 92 | apply divmod_lt_q with (t := 32) in e; 93 | change (32+32) with 64; assumption. 94 | Qed. 95 | 96 | (** ** ascii8への変換 *) 97 | Definition list_of_ascii8 (x : ascii8) := 98 | x :: nil. 99 | 100 | Definition list_of_ascii16 (p : ascii16) := 101 | match p with 102 | (x1,x2) => (list_of_ascii8 x1) ++ (list_of_ascii8 x2) 103 | end. 104 | 105 | Definition list_of_ascii32 (p : ascii32) := 106 | match p with 107 | (x1,x2) => (list_of_ascii16 x1) ++ (list_of_ascii16 x2) 108 | end. 109 | 110 | Definition list_of_ascii64 (p : ascii64) := 111 | match p with 112 | (x1,x2) => (list_of_ascii32 x1) ++ (list_of_ascii32 x2) 113 | end. 114 | 115 | Lemma list_of_ascii8_eq : forall c1 c2, 116 | list_of_ascii8 c1 = list_of_ascii8 c2 -> 117 | c1 = c2. 118 | Proof. 119 | intros. 120 | unfold list_of_ascii8 in H. 121 | inversion H. 122 | reflexivity. 123 | Qed. 124 | 125 | Lemma list_of_ascii16_eq : forall c1 c2, 126 | list_of_ascii16 c1 = list_of_ascii16 c2 -> 127 | c1 = c2. 128 | Proof. 129 | intros. 130 | destruct c1; destruct c2. 131 | inversion H. 132 | reflexivity. 133 | Qed. 134 | 135 | Lemma list_of_ascii32_eq : forall c1 c2, 136 | list_of_ascii32 c1 = list_of_ascii32 c2 -> 137 | c1 = c2. 138 | Proof. 139 | intros. 140 | destruct c1; destruct c2. 141 | destruct a; destruct a0; destruct a1; destruct a2. 142 | inversion H. 143 | reflexivity. 144 | Qed. 145 | 146 | Lemma list_of_ascii64_eq : forall c1 c2, 147 | list_of_ascii64 c1 = list_of_ascii64 c2 -> 148 | c1 = c2. 149 | Proof. 150 | intros. 151 | destruct c1; destruct c2. 152 | destruct a; destruct a0; destruct a1; destruct a2. 153 | destruct a; destruct a3; destruct a0; destruct a4; 154 | destruct a1; destruct a5; destruct a2; destruct a6. 155 | inversion H. 156 | reflexivity. 157 | Qed. 158 | 159 | (** 0でないことの証明 *) 160 | Lemma ascii8_not_O: forall n, 161 | 0 < n < pow 8 -> 162 | "000" <> ascii8_of_nat n. 163 | Proof. 164 | intros. 165 | destruct H. 166 | apply nat_ascii8_embedding in H0. 167 | destruct (ascii8_of_nat n). 168 | intro. 169 | destruct b; destruct b0; destruct b1; destruct b2; destruct b3; destruct b4; destruct b5; destruct b6; inversion H1. 170 | compute in H0. 171 | rewrite <- H0 in H. 172 | inversion H. 173 | Qed. 174 | 175 | Lemma ascii16_not_O: forall n, 176 | 0 < n < pow 16 -> 177 | ("000","000") <> ascii16_of_nat n. 178 | Proof. 179 | intros. 180 | unfold ascii16_of_nat. 181 | destruct divmod. 182 | destruct H. 183 | intro. 184 | inversion H1. 185 | generalize e; intro. 186 | apply divmod_not_O in e; auto with pow. 187 | decompose [or] e. 188 | apply ascii8_not_O in H3; auto. 189 | apply divmod_lt_q with (t:=8) in e0; auto with pow. 190 | 191 | apply ascii8_not_O in H4; auto with pow. 192 | Qed. 193 | 194 | Lemma ascii32_not_O: forall n, 195 | 0 < n < pow 32 -> 196 | ("000","000",("000","000")) <> ascii32_of_nat n. 197 | Proof. 198 | intros. 199 | unfold ascii32_of_nat. 200 | destruct divmod. 201 | destruct H. 202 | intro. 203 | inversion H1. 204 | generalize e; intro. 205 | apply divmod_not_O in e. 206 | decompose [or] e. 207 | apply divmod_lt_q with (t:=16) in e0. 208 | apply ascii16_not_O in H3. 209 | contradiction. 210 | 211 | split; assumption. 212 | 213 | assumption. 214 | 215 | exact H0. 216 | 217 | apply ascii16_not_O in H4. 218 | contradiction. 219 | 220 | split; assumption. 221 | 222 | assumption. 223 | 224 | apply pow_lt_O. 225 | Qed. 226 | 227 | (* ** 2^n未満なら等価性が変らないことの証明 *) 228 | Lemma ascii8_of_nat_eq : forall n m, 229 | n < pow 8 -> 230 | m < pow 8 -> 231 | ascii8_of_nat n = ascii8_of_nat m -> 232 | n = m. 233 | Proof. 234 | intros. 235 | rewrite <- (nat_ascii8_embedding n), <- (nat_ascii8_embedding m), <- H1; auto. 236 | Qed. 237 | 238 | Lemma ascii16_of_nat_eq : forall n m, 239 | n < pow 16 -> 240 | m < pow 16 -> 241 | ascii16_of_nat n = ascii16_of_nat m -> 242 | n = m. 243 | Proof. 244 | intros. 245 | rewrite <- (nat_ascii16_embedding n), <- (nat_ascii16_embedding m), <- H1; auto. 246 | Qed. 247 | 248 | Lemma ascii32_of_nat_eq : forall n m, 249 | n < pow 32 -> 250 | m < pow 32 -> 251 | ascii32_of_nat n = ascii32_of_nat m -> 252 | n = m. 253 | Proof. 254 | intros. 255 | rewrite <- (nat_ascii32_embedding n), <- (nat_ascii32_embedding m), <- H1; auto. 256 | Qed. 257 | 258 | Lemma ascii8_of_nat_O: 259 | "000" = ascii8_of_nat 0. 260 | Proof. 261 | compute. 262 | reflexivity. 263 | Qed. 264 | 265 | Lemma ascii16_of_nat_O: 266 | ("000", "000") = ascii16_of_nat 0. 267 | Proof. 268 | unfold ascii16_of_nat. 269 | destruct divmod. 270 | apply divmod_O_pow in e. 271 | decompose [and] e. 272 | rewrite H, H0. 273 | rewrite <- ascii8_of_nat_O. 274 | reflexivity. 275 | Qed. 276 | 277 | Lemma ascii32_of_nat_O: 278 | (("000", "000"),("000","000")) = ascii32_of_nat 0. 279 | Proof. 280 | unfold ascii32_of_nat. 281 | destruct divmod. 282 | apply divmod_O_pow in e. 283 | decompose [and] e. 284 | rewrite H, H0. 285 | rewrite <- ascii16_of_nat_O. 286 | reflexivity. 287 | Qed. 288 | 289 | (* lengthが等しいことの証明 *) 290 | Lemma ascii8_length : forall c1 c2, 291 | length (list_of_ascii8 c1) = length (list_of_ascii8 c2). 292 | Proof. 293 | auto. 294 | Qed. 295 | 296 | Lemma ascii16_length : forall c1 c2, 297 | length (list_of_ascii16 c1) = length (list_of_ascii16 c2). 298 | Proof. 299 | destruct c1,c2. 300 | auto. 301 | Qed. 302 | 303 | Lemma ascii32_length : forall c1 c2, 304 | length (list_of_ascii32 c1) = length (list_of_ascii32 c2). 305 | Proof. 306 | destruct c1 as [a1 a2] ,c2 as [a3 a4]. 307 | destruct a1,a2,a3,a4. 308 | auto. 309 | Qed. 310 | 311 | Lemma ascii64_length : forall c1 c2, 312 | length (list_of_ascii64 c1) = length (list_of_ascii64 c2). 313 | Proof. 314 | destruct c1 as [a1 a2] ,c2 as [a3 a4]. 315 | destruct a1 as [b1 b2], a2 as [b3 b4], a3 as [b5 b6], a4 as [b7 b8]. 316 | destruct b1,b2,b3,b4,b5,b6,b7,b8. 317 | auto. 318 | Qed. 319 | 320 | Lemma ascii5 : forall n b1 b2 b3 b4 b5 b6 b7 b8, 321 | n < pow 5 -> 322 | Ascii b1 b2 b3 b4 b5 b6 b7 b8 = ascii8_of_nat n -> 323 | b6 = false /\ b7 = false /\ b8 = false. 324 | Proof. 325 | intros. 326 | simpl in H. 327 | do 32 (destruct n; [ inversion H0; auto | idtac]). 328 | do 32 (apply Lt.lt_S_n in H). 329 | inversion H. 330 | Qed. 331 | 332 | Hint Resolve ascii16_length ascii32_length ascii64_length 333 | list_of_ascii8_eq list_of_ascii16_eq list_of_ascii32_eq list_of_ascii64_eq 334 | : ascii. -------------------------------------------------------------------------------- /proof/OCamlBase.v: -------------------------------------------------------------------------------- 1 | Require Export String. 2 | Require Export List. 3 | Require Export ExtractUtil. 4 | Require Export Util. 5 | 6 | Open Scope string_scope. 7 | 8 | Notation "op ; x" := (semicolon_flipped x op) (at level 50). 9 | -------------------------------------------------------------------------------- /proof/OMakefile: -------------------------------------------------------------------------------- 1 | open CoqBuildRule 2 | .PHONY: all clean 3 | 4 | FILES[] = 5 | Pow 6 | MultiByte 7 | ListUtil 8 | Object 9 | SerializeSpec 10 | Prefix 11 | Soundness 12 | SerializeImplement 13 | SerializedList 14 | DeserializeImplement 15 | OCamlBase 16 | Util 17 | ExtractUtil 18 | Main 19 | 20 | .DEFAULT: all 21 | 22 | all: msgpackCore.ml msgpackCore.mli 23 | msgpackCore.ml msgpackCore.mli: $(CoqProof $(FILES)) 24 | echo "Proof complete" 25 | clean: 26 | rm -rf *.vo *.glob *~ *.omc .omakedb .omakedb.lock *.cm[iox] *.annot *.o msgpackCore.ml msgpackCore.mli 27 | -------------------------------------------------------------------------------- /proof/Object.v: -------------------------------------------------------------------------------- 1 | (* -*- coding:utf-8 -*- *) 2 | Require Import List Ascii. 3 | Require Import Pow MultiByte ListUtil. 4 | 5 | Open Scope char_scope. 6 | 7 | (** MsgPackで使うオブジェクトの定義 *) 8 | Inductive object := 9 | | Bool (_ : bool) 10 | | Nil 11 | | PFixnum (_ : ascii8) 12 | | NFixnum (_ : ascii8) 13 | | Uint8 (_ : ascii8) 14 | | Uint16 (_ : ascii16) 15 | | Uint32 (_ : ascii32) 16 | | Uint64 (_ : ascii64) 17 | | Int8 (_ : ascii8) 18 | | Int16 (_ : ascii16) 19 | | Int32 (_ : ascii32) 20 | | Int64 (_ : ascii64) 21 | | Float (_ : ascii32) 22 | | Double (_ : ascii64) 23 | | FixRaw (_ : list ascii8) 24 | | Raw16 (_ : list ascii8) 25 | | Raw32 (_ : list ascii8) 26 | | FixArray ( _ : list object) 27 | | Array16 ( _ : list object) 28 | | Array32 ( _ : list object) 29 | | FixMap ( _ : list (object * object)%type) 30 | | Map16 ( _ : list (object * object)%type) 31 | | Map32 ( _ : list (object * object)%type). 32 | 33 | (** 妥当なオブジェクトの定義 *) 34 | Inductive Valid : object -> Prop := 35 | | VBool : forall b, 36 | Valid (Bool b) 37 | | VPFixNum : forall n, 38 | nat_of_ascii8 n < 128 -> Valid (PFixnum n) 39 | | VNFixNum : forall n, 40 | (* 負の数を導入したくないので、補数表現を使う *) 41 | 223 < nat_of_ascii8 n /\ nat_of_ascii8 n < 256 -> Valid (NFixnum n) 42 | | VUint8 : forall c, Valid (Uint8 c) 43 | | VUint16 : forall c, Valid (Uint16 c) 44 | | VUint32 : forall c, Valid (Uint32 c) 45 | | VUint64 : forall c, Valid (Uint64 c) 46 | | VInt8 : forall c, Valid (Int8 c) 47 | | VInt16 : forall c, Valid (Int16 c) 48 | | VInt32 : forall c, Valid (Int32 c) 49 | | VInt64 : forall c, Valid (Int64 c) 50 | | VFloat : forall c, Valid (Float c) 51 | | VDouble : forall c, Valid (Double c) 52 | | VFixRaw : forall xs, 53 | length xs < pow 5 -> Valid (FixRaw xs) 54 | | VRaw16 : forall xs, 55 | length xs < pow 16 -> Valid (Raw16 xs) 56 | | VRaw32 : forall xs, 57 | length xs < pow 32 -> Valid (Raw32 xs) 58 | | VFixArrayNil : 59 | Valid (FixArray []) 60 | | VFixArrayCons : forall x xs, 61 | Valid x -> 62 | Valid (FixArray xs) -> 63 | length (x::xs) < pow 4 -> 64 | Valid (FixArray (x::xs)) 65 | | VArray16Nil : 66 | Valid (Array16 []) 67 | | VArray16Cons: forall x xs, 68 | Valid x -> 69 | Valid (Array16 xs) -> 70 | length (x::xs) < pow 16 -> 71 | Valid (Array16 (x::xs)) 72 | | VArray32Nil : 73 | Valid (Array32 []) 74 | | VArray32Cons : forall x xs, 75 | Valid x -> 76 | Valid (Array32 xs) -> 77 | length (x::xs) < pow 32 -> 78 | Valid (Array32 (x::xs)) 79 | | VFixMapNil: 80 | Valid (FixMap []) 81 | | VFixMapCons : forall k v xs, 82 | Valid k -> 83 | Valid v -> 84 | Valid (FixMap xs) -> 85 | length ((k,v)::xs) < pow 4 -> 86 | Valid (FixMap ((k,v)::xs)) 87 | | VMap16Nil : 88 | Valid (Map16 []) 89 | | VMap16Cons : forall k v xs, 90 | Valid k -> 91 | Valid v -> 92 | Valid (Map16 xs) -> 93 | length ((k,v)::xs) < pow 16 -> 94 | Valid (Map16 ((k,v)::xs)) 95 | | VMap32Nil : 96 | Valid (Map32 []) 97 | | VMap32Cons : forall k v xs, 98 | Valid k -> 99 | Valid v -> 100 | Valid (Map32 xs) -> 101 | length ((k,v)::xs) < pow 32 -> 102 | Valid (Map32 ((k,v)::xs)). 103 | 104 | Lemma varray16_inv1: forall x xs, 105 | Valid (Array16 (x::xs)) -> 106 | ("000", "000") <> ascii16_of_nat (length (x :: xs)). 107 | Proof. 108 | intros. 109 | apply ascii16_not_O. 110 | split; [ apply length_lt_O | inversion H; auto ]. 111 | Qed. 112 | 113 | Lemma varray16_inv2 : forall A (x y : A) xs ys, 114 | pow 16 > length (x :: xs) -> 115 | pow 16 > length (y :: ys) -> 116 | ascii16_of_nat (length (x :: xs)) = ascii16_of_nat (length (y :: ys)) -> 117 | ascii16_of_nat (length xs) = ascii16_of_nat (length ys). 118 | Proof. 119 | intros. 120 | apply ascii16_of_nat_eq in H1; auto. 121 | Qed. 122 | 123 | (* Better induction principle for object. Pattern copied from 124 | http://adam.chlipala.net/cpdt/html/InductiveTypes.html *) 125 | Section ObjectInd'. 126 | Variable P: object -> Prop. 127 | 128 | Let P_both p := P (fst p) /\ P (snd p). 129 | 130 | Hypothesis PBool: forall x, P (Bool x). 131 | Hypothesis PNil: P Nil. 132 | Hypothesis PPFixnum: forall x, P (PFixnum x). 133 | Hypothesis PNFixnum: forall x, P (NFixnum x). 134 | Hypothesis PUint8 : forall x, P (Uint8 x). 135 | Hypothesis PUint16 : forall x, P (Uint16 x). 136 | Hypothesis PUint32 : forall x, P (Uint32 x). 137 | Hypothesis PUint64 : forall x, P (Uint64 x). 138 | Hypothesis PInt8 : forall x, P (Int8 x). 139 | Hypothesis PInt16 : forall x, P (Int16 x). 140 | Hypothesis PInt32 : forall x, P (Int32 x). 141 | Hypothesis PInt64 : forall x, P (Int64 x). 142 | Hypothesis PFloat : forall x, P (Float x). 143 | Hypothesis PDouble : forall x, P (Double x). 144 | Hypothesis PFixRaw : forall x, P (FixRaw x). 145 | Hypothesis PRaw16 : forall x, P (Raw16 x). 146 | Hypothesis PRaw32 : forall x, P (Raw32 x). 147 | 148 | Hypothesis PFixArray: forall os, Forall P os -> P (FixArray os). 149 | Hypothesis PArray16: forall os, Forall P os -> P (Array16 os). 150 | Hypothesis PArray32: forall os, Forall P os -> P (Array32 os). 151 | Hypothesis PFixMap: forall ps, Forall P_both ps -> P (FixMap ps). 152 | Hypothesis PMap16: forall ps, Forall P_both ps -> P (Map16 ps). 153 | Hypothesis PMap32: forall ps, Forall P_both ps -> P (Map32 ps). 154 | 155 | Let P_all object_ind' := fix F os := 156 | match os return Forall P os with 157 | | [] => Forall_nil P 158 | | o :: os => Forall_cons o (object_ind' o) (F os) 159 | end. 160 | 161 | Let P_all_pairs object_ind' := fix F ps := 162 | match ps return Forall P_both ps with 163 | | [] => Forall_nil P_both 164 | | (k,v) :: ps => Forall_cons (k,v) (@conj (P k) (P v) (object_ind' k) (object_ind' v)) (F ps) 165 | end. 166 | 167 | Fixpoint object_ind' o: P o := 168 | match o return P o with 169 | | Nil => PNil 170 | | Bool x => PBool x 171 | | PFixnum x => PPFixnum x 172 | | NFixnum x => PNFixnum x 173 | | Uint8 x => PUint8 x 174 | | Uint16 x => PUint16 x 175 | | Uint32 x => PUint32 x 176 | | Uint64 x => PUint64 x 177 | | Int8 x => PInt8 x 178 | | Int16 x => PInt16 x 179 | | Int32 x => PInt32 x 180 | | Int64 x => PInt64 x 181 | | Float x => PFloat x 182 | | Double x => PDouble x 183 | | FixRaw x => PFixRaw x 184 | | Raw16 x => PRaw16 x 185 | | Raw32 x => PRaw32 x 186 | | FixArray os => PFixArray os (P_all object_ind' os) 187 | | Array16 os => PArray16 os (P_all object_ind' os) 188 | | Array32 os => PArray32 os (P_all object_ind' os) 189 | | FixMap ps => PFixMap ps (P_all_pairs object_ind' ps) 190 | | Map16 ps => PMap16 ps (P_all_pairs object_ind' ps) 191 | | Map32 ps => PMap32 ps (P_all_pairs object_ind' ps) 192 | end. 193 | End ObjectInd'. 194 | -------------------------------------------------------------------------------- /proof/Pow.v: -------------------------------------------------------------------------------- 1 | (** 2 | 算術演算関連の補題 3 | *) 4 | 5 | Require Import Omega NArith Euclid. 6 | 7 | (** ** 算術演算 *) 8 | Lemma mult_S_lt_reg_l : 9 | forall n m p, 0 < n -> n * m < n * p -> m < p. 10 | Proof. 11 | intros. 12 | destruct n. 13 | inversion H. 14 | 15 | elim (le_or_lt m p). 16 | intro. 17 | inversion H1. 18 | rewrite H2 in H0. 19 | elim (lt_irrefl _ H0). 20 | omega. 21 | 22 | intro. 23 | apply (mult_S_lt_compat_l n _ _) in H1. 24 | omega. 25 | Qed. 26 | 27 | Lemma plus_elim: forall p a b, 28 | a + p < b -> a < b. 29 | Proof. 30 | intros. 31 | omega. 32 | Qed. 33 | 34 | (** ** pow *) 35 | Fixpoint pow (n : nat) := 36 | match n with 37 | | 0 => 38 | 1 39 | | S n' => 40 | 2 * pow n' 41 | end. 42 | 43 | Lemma pow_lt_O : forall n, 44 | 0 < pow n. 45 | Proof. 46 | induction n; simpl; omega. 47 | Qed. 48 | 49 | Hint Resolve pow_lt_O. 50 | 51 | Lemma pow_add: forall n m, 52 | pow n * pow m = pow (n + m). 53 | Proof. 54 | induction n; intros. 55 | simpl in *. 56 | omega. 57 | 58 | simpl. 59 | repeat rewrite plus_0_r. 60 | rewrite <- IHn, mult_plus_distr_r. 61 | reflexivity. 62 | Qed. 63 | 64 | (** ** divmod *) 65 | Definition divmod (n m : nat) (P : 0 < m) := 66 | eucl_dev m P n. 67 | 68 | Lemma divmod_lt_q : forall (n m q r s t: nat), 69 | n < pow (s + t) -> 70 | n = q * pow s + r -> 71 | q < pow t. 72 | Proof. 73 | intros. 74 | rewrite H0 in H. 75 | apply plus_elim in H. 76 | rewrite <- pow_add, mult_comm in H. 77 | apply mult_S_lt_reg_l in H. 78 | assumption. 79 | 80 | apply pow_lt_O. 81 | Qed. 82 | 83 | Lemma divmod_not_O: forall n m q r, 84 | 0 < n -> 85 | 0 < m -> 86 | n = q * m + r -> 87 | 0 < q \/ 0 < r. 88 | Proof. 89 | intros. 90 | rewrite H1 in H. 91 | destruct q. 92 | simpl in H. 93 | right. 94 | assumption. 95 | 96 | left. 97 | omega. 98 | Qed. 99 | 100 | Lemma divmod_O: forall n q r, 101 | 0 = q * n + r -> 102 | n <> 0 -> 103 | q = 0 /\ r = 0. 104 | Proof. 105 | intros. 106 | destruct q; destruct n; destruct r; try omega. 107 | simpl in H. 108 | discriminate. 109 | 110 | simpl in H. 111 | discriminate. 112 | Qed. 113 | 114 | Lemma divmod_O_pow: forall n q r, 115 | 0 = q * pow n + r -> 116 | q = 0 /\ r = 0. 117 | Proof. 118 | intros. 119 | apply (divmod_O (pow n) _ _); auto. 120 | intro. 121 | generalize (pow_lt_O n); intros. 122 | omega. 123 | Qed. 124 | 125 | Lemma plus_O : forall n, 126 | n + 0 = n. 127 | Proof. 128 | Admitted. 129 | 130 | Lemma plus_double : forall n, 131 | n < n + n. 132 | Admitted. 133 | 134 | Lemma pow_lt : forall n m, 135 | n < m -> 136 | pow n < pow m. 137 | Proof. 138 | induction n; induction m; simpl; intros. 139 | inversion H. 140 | 141 | destruct m; auto. 142 | transitivity (pow (S m)); 143 | [ apply IHm | idtac]; 144 | omega. 145 | 146 | inversion H. 147 | 148 | simpl in IHm. 149 | inversion H; simpl. 150 | repeat (rewrite plus_O in *). 151 | apply (Plus.plus_lt_compat_r O _). 152 | transitivity (pow n); auto. 153 | apply plus_double. 154 | 155 | assert (S n < m); auto. 156 | apply IHm in H2. 157 | transitivity (pow m); auto. 158 | rewrite plus_O. 159 | apply plus_double. 160 | Qed. 161 | 162 | Hint Resolve pow_lt pow_lt_O: pow. 163 | -------------------------------------------------------------------------------- /proof/Prefix.v: -------------------------------------------------------------------------------- 1 | Require Import List Ascii. 2 | Require Import ListUtil Object SerializeSpec MultiByte ProofUtil Pow. 3 | 4 | Definition Prefix obj1 x : Prop := forall obj2 y xs ys, 5 | Serialized obj1 x -> 6 | Serialized obj2 y -> 7 | Valid obj1 -> 8 | Valid obj2 -> 9 | x ++ xs = y ++ ys -> 10 | x = y. 11 | 12 | Ltac destruct_serialize obj y := 13 | match goal with 14 | | [ H1 : _ ++ _ = y ++ _, 15 | H2 : Serialized obj y |- _ ] => 16 | destruct y as [ | a ] ; 17 | [ inversion H2 | inversion H1 ; rewrite_for a; inversion H2 ]; 18 | auto 19 | end. 20 | 21 | (* 結果が1バイトになる変換 *) 22 | Ltac straight_forward := 23 | intros; 24 | unfold Prefix; 25 | intros obj2 y xs ys S1 S2 V1 V2 Happ; 26 | destruct_serialize obj2 y. 27 | 28 | Lemma prefix_true : 29 | Prefix (Bool true) ["195"]. 30 | Proof. 31 | straight_forward. 32 | Qed. 33 | 34 | Lemma prefix_false : 35 | Prefix (Bool false) ["194"]. 36 | Proof. 37 | straight_forward. 38 | Qed. 39 | 40 | Lemma prefix_nil : 41 | Prefix Nil ["192"]. 42 | Proof. 43 | straight_forward. 44 | Qed. 45 | 46 | Lemma prefix_pfixnum: forall x1 x2 x3 x4 x5 x6 x7, 47 | Prefix (PFixnum (Ascii x1 x2 x3 x4 x5 x6 x7 false)) 48 | [Ascii x1 x2 x3 x4 x5 x6 x7 false]. 49 | Proof. 50 | straight_forward. 51 | Qed. 52 | 53 | Lemma prefix_nfixnum : forall x1 x2 x3 x4 x5, 54 | Prefix (NFixnum (Ascii x1 x2 x3 x4 x5 true true true)) 55 | [Ascii x1 x2 x3 x4 x5 true true true]. 56 | Proof. 57 | straight_forward. 58 | Qed. 59 | 60 | (* 結果が固定長多バイトになる変換 *) 61 | Lemma prefix_same : forall A (x y xs ys : list A), 62 | x ++ xs = y ++ ys -> 63 | length x = length y -> 64 | x = y. 65 | Proof. 66 | induction x; induction y; intros; auto. 67 | simpl in H0. 68 | discriminate. 69 | 70 | simpl in H0. 71 | discriminate. 72 | 73 | inversion H. 74 | inversion H0. 75 | apply IHx in H3; auto. 76 | rewrite_for y. 77 | reflexivity. 78 | Qed. 79 | 80 | Ltac same_as_uint8 := 81 | unfold Prefix; 82 | intros c obj2 y xs ys S1 S2 V1 V2 Happ; 83 | destruct_serialize obj2 y; 84 | rewrite_for y; 85 | apply prefix_same in Happ; simpl; auto with ascii. 86 | 87 | Lemma prefix_uint8 : forall c, 88 | Prefix (Uint8 c) ("204"::list_of_ascii8 c). 89 | Proof. 90 | same_as_uint8. 91 | Qed. 92 | 93 | Lemma prefix_uint16: forall c, 94 | Prefix (Uint16 c) ("205"::list_of_ascii16 c). 95 | Proof. 96 | same_as_uint8. 97 | Qed. 98 | 99 | Lemma prefix_uint32: forall c, 100 | Prefix (Uint32 c) ("206"::list_of_ascii32 c). 101 | Proof. 102 | same_as_uint8. 103 | Qed. 104 | 105 | Lemma prefix_uint64 : forall c, 106 | Prefix (Uint64 c) ("207"::list_of_ascii64 c). 107 | Proof. 108 | same_as_uint8. 109 | Qed. 110 | 111 | Lemma prefix_int8 : forall c, 112 | Prefix (Int8 c) ("208"::list_of_ascii8 c). 113 | Proof. 114 | same_as_uint8. 115 | Qed. 116 | 117 | Lemma prefix_int16 : forall c, 118 | Prefix (Int16 c) ("209"::list_of_ascii16 c). 119 | Proof. 120 | same_as_uint8. 121 | Qed. 122 | 123 | Lemma prefix_int32 : forall c, 124 | Prefix (Int32 c) ("210"::list_of_ascii32 c). 125 | Proof. 126 | same_as_uint8. 127 | Qed. 128 | 129 | Lemma prefix_int64 : forall c, 130 | Prefix (Int64 c) ("211"::list_of_ascii64 c). 131 | Proof. 132 | same_as_uint8. 133 | Qed. 134 | 135 | Lemma prefix_float : forall c, 136 | Prefix (Float c) ("202"::list_of_ascii32 c). 137 | Proof. 138 | same_as_uint8. 139 | Qed. 140 | 141 | Lemma prefix_double : forall c, 142 | Prefix (Double c) ("203"::list_of_ascii64 c). 143 | Proof. 144 | same_as_uint8. 145 | Qed. 146 | 147 | Lemma app_length_eq : forall A (xs ys zs ws : list A), 148 | xs ++zs = ys ++ ws -> 149 | length xs = length ys -> 150 | xs = ys. 151 | Proof. 152 | induction xs; induction ys; simpl; intros; auto. 153 | inversion H0. 154 | 155 | inversion H0. 156 | 157 | inversion H. 158 | inversion H0. 159 | assert (xs = ys); [| rewrite_for xs; auto]. 160 | apply (IHxs _ zs ws); auto. 161 | Qed. 162 | 163 | Lemma prefix_fixraw : forall cs b1 b2 b3 b4 b5, 164 | Ascii b1 b2 b3 b4 b5 false false false = ascii8_of_nat (length cs) -> 165 | Prefix (FixRaw cs) ((Ascii b1 b2 b3 b4 b5 true false true)::cs). 166 | Proof. 167 | unfold Prefix. 168 | intros. 169 | destruct_serialize obj2 y. 170 | rewrite_for obj2. 171 | rewrite_for y. 172 | inversion H2. 173 | inversion H3. 174 | assert (cs = cs0); [| rewrite_for cs; auto ]. 175 | apply (app_length_eq _ _ _ xs ys); auto. 176 | rewrite <- (nat_ascii8_embedding (length cs)), 177 | <- (nat_ascii8_embedding (length cs0)). 178 | rewrite <- H, <- H8. 179 | reflexivity. 180 | 181 | transitivity (pow 5); auto with pow. 182 | 183 | transitivity (pow 5); auto with pow. 184 | Qed. 185 | 186 | Lemma prefix_raw16 : forall cs s1 s2, 187 | (s1,s2) = ascii16_of_nat (length cs) -> 188 | Prefix (Raw16 cs) ("218"::s1::s2::cs). 189 | Proof. 190 | unfold Prefix. 191 | intros. 192 | destruct_serialize obj2 y. 193 | rewrite_for obj2. 194 | rewrite_for y. 195 | inversion H2. 196 | inversion H3. 197 | inversion H7. 198 | assert (cs = cs0); [| rewrite_for cs; auto ]. 199 | apply (app_length_eq _ _ _ xs ys); auto. 200 | rewrite <- (nat_ascii16_embedding (length cs)), 201 | <- (nat_ascii16_embedding (length cs0)); auto. 202 | rewrite <- H, <- H8, H12, H13. 203 | reflexivity. 204 | Qed. 205 | 206 | Lemma prefix_raw32 : forall cs s1 s2 s3 s4, 207 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length cs) -> 208 | Prefix (Raw32 cs) ("219"::s1::s2::s3::s4::cs). 209 | Proof. 210 | unfold Prefix. 211 | intros. 212 | destruct_serialize obj2 y. 213 | rewrite_for obj2. 214 | rewrite_for y. 215 | inversion H2. 216 | inversion H3. 217 | inversion H7. 218 | assert (cs = cs0); [| rewrite_for cs; auto ]. 219 | apply (app_length_eq _ _ _ xs ys); auto. 220 | rewrite <- (nat_ascii32_embedding (length cs)), 221 | <- (nat_ascii32_embedding (length cs0)); auto. 222 | rewrite <- H, <- H8, H12, H13, H14, H15. 223 | reflexivity. 224 | Qed. 225 | 226 | Lemma prefix_fixarray_nil: 227 | Prefix (FixArray []) ["144"]. 228 | Proof. 229 | straight_forward. 230 | apply ascii8_not_O in H7; [ contradiction |]. 231 | rewrite_for obj2. 232 | inversion V2. 233 | split; [ simpl; omega |]. 234 | transitivity (pow 4); [ exact H13 | apply pow_lt; auto ]. 235 | Qed. 236 | 237 | Lemma prefix_array16_nil: 238 | Prefix (Array16 []) ["220"; "000"; "000"]. 239 | Proof. 240 | unfold Prefix; intros. 241 | destruct_serialize obj2 y. 242 | rewrite_for obj2. 243 | rewrite_for y. 244 | inversion H3. 245 | rewrite <- H9, <- H11 in *. 246 | assert (("000", "000") <> ascii16_of_nat ((length (x::xs0)))); try contradiction. 247 | inversion H2. 248 | apply ascii16_not_O. 249 | split; auto. 250 | simpl. 251 | omega. 252 | Qed. 253 | 254 | Lemma prefix_array32_nil: 255 | Prefix (Array32 []) ["221"; "000"; "000";"000"; "000"]. 256 | Proof. 257 | unfold Prefix; intros. 258 | destruct_serialize obj2 y. 259 | rewrite_for obj2. 260 | rewrite_for y. 261 | inversion H3. 262 | rewrite <- H9, <- H11, <- H12, <- H13 in *. 263 | assert (("000", "000",("000","000")) <> ascii32_of_nat ((length (x::xs0)))); try contradiction. 264 | inversion H2. 265 | apply ascii32_not_O. 266 | split; auto. 267 | simpl. 268 | omega. 269 | Qed. 270 | 271 | Lemma prefix_fixmap_nil: 272 | Prefix (FixMap []) ["128"]. 273 | Proof. 274 | unfold Prefix; intros. 275 | destruct_serialize obj2 y. 276 | rewrite_for obj2. 277 | apply ascii8_not_O in H12; [ contradiction |]. 278 | inversion H2. 279 | split; [ simpl; omega |]. 280 | transitivity (pow 4); [ exact H21 |]. 281 | apply pow_lt. 282 | auto. 283 | Qed. 284 | 285 | Lemma prefix_map16_nil: 286 | Prefix (Map16 []) ["222"; "000"; "000"]. 287 | Proof. 288 | unfold Prefix; intros. 289 | destruct_serialize obj2 y. 290 | rewrite_for obj2. 291 | rewrite_for y. 292 | inversion H3. 293 | rewrite <- H10, <- H12 in *. 294 | assert (("000", "000") <> ascii16_of_nat ((length ((x1, x2)::xs0)))); try contradiction. 295 | inversion H2. 296 | apply ascii16_not_O. 297 | split. 298 | simpl. 299 | omega. 300 | 301 | exact H19. 302 | Qed. 303 | 304 | Lemma prefix_map32_nil: 305 | Prefix (Map32 []) ["223"; "000"; "000";"000"; "000"]. 306 | Proof. 307 | unfold Prefix; intros. 308 | destruct_serialize obj2 y. 309 | rewrite_for obj2. 310 | rewrite_for y. 311 | inversion H3. 312 | rewrite <- H10, <- H12, <- H13, <- H14 in *. 313 | assert (("000", "000",("000","000")) <> ascii32_of_nat ((length ((x1, x2)::xs0)))); try contradiction. 314 | inversion H2. 315 | apply ascii32_not_O. 316 | split. 317 | simpl. 318 | omega. 319 | 320 | exact H21. 321 | Qed. 322 | 323 | Lemma prefix_fixarray_cons: forall x xs y ys b1 b2 b3 b4 b5 b6 b7 b8, 324 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 325 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length (x::xs)) -> 326 | Serialized x y -> 327 | Prefix x y -> 328 | Serialized (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 329 | Prefix (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 330 | Prefix (FixArray (x :: xs)) ((Ascii b5 b6 b7 b8 true false false true)::y ++ ys). 331 | Proof. 332 | unfold Prefix. 333 | intros. 334 | destruct_serialize obj2 y0; rewrite_for y0; rewrite_for obj2. 335 | inversion H6. 336 | rewrite_for b5. 337 | rewrite_for b6. 338 | rewrite_for b7. 339 | rewrite_for b8. 340 | apply ascii8_not_O in H0; [contradiction |]. 341 | split; [ simpl; omega |]. 342 | inversion H7. 343 | transitivity (pow 4); [ exact H19 | apply pow_lt; auto]. 344 | 345 | assert (y ++ ys = y1 ++ ys1); [| rewrite_for (y++ys); reflexivity ]. 346 | generalize H12; intro Happ; clear H12. 347 | rewrite <- (app_assoc y ys xs0), <- (app_assoc y1 ys1 ys0) in Happ. 348 | inversion H7. 349 | inversion H8. 350 | apply (H2 x0 y1 (ys++xs0) (ys1++ys0))in H1; auto. 351 | rewrite_for y1. 352 | apply app_same in Happ. 353 | apply (H4 (FixArray xs1) (Ascii b0 b9 b10 b11 true false false true :: ys1) xs0 ys0) in H3; auto. 354 | inversion H3. 355 | reflexivity. 356 | 357 | simpl. 358 | unfold ascii8 in *. 359 | rewrite <- Happ. 360 | rewrite H0 in H18. 361 | apply ascii8_of_nat_eq in H18; [ 362 | | transitivity (pow 4); [| apply pow_lt]; auto 363 | | transitivity (pow 4); [| apply pow_lt]; auto ]. 364 | simpl in H18. 365 | inversion H18. 366 | rewrite <- H28 in H16. 367 | rewrite <- H16 in H. 368 | inversion H. 369 | reflexivity. 370 | Qed. 371 | 372 | Lemma prefix_array16_cons: forall x xs y ys s1 s2 t1 t2, 373 | (t1, t2) = ascii16_of_nat (length xs) -> 374 | (s1, s2) = ascii16_of_nat (length (x :: xs)) -> 375 | Serialized x y -> 376 | Prefix x y -> 377 | Serialized (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 378 | Prefix (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 379 | Prefix (Array16 (x::xs)) ("220"::s1::s2::y ++ ys). 380 | Proof. 381 | unfold Prefix. 382 | intros. 383 | destruct_serialize obj2 y0. 384 | rewrite_for y0. 385 | inversion H9. 386 | rewrite_for s1. 387 | rewrite_for s2. 388 | apply ascii16_not_O in H0; [ contradiction |]. 389 | inversion H7. 390 | split; [ simpl; omega | exact H17 ]. 391 | 392 | rewrite_for y0. 393 | rewrite_for obj2. 394 | inversion H9. 395 | rewrite_for s0. 396 | rewrite_for s3. 397 | assert( y++ ys = y1 ++ ys1); [| rewrite_for (y++ys); reflexivity ]. 398 | rewrite <- (app_assoc y ys xs0), <- (app_assoc y1 ys1 ys0) in H18. 399 | inversion H7. 400 | inversion H8. 401 | apply (H2 x0 y1 (ys++xs0) (ys1++ys0))in H1; auto. 402 | rewrite_for y1. 403 | apply app_same in H18. 404 | apply (H4 (Array16 xs1) ("220" :: t0 :: t3 :: ys1) xs0 ys0) in H3; auto. 405 | inversion H3. 406 | reflexivity. 407 | 408 | simpl. 409 | unfold ascii8 in *. 410 | rewrite <- H18. 411 | rewrite H0 in H13. 412 | apply ascii16_of_nat_eq in H13; auto. 413 | simpl in H13. 414 | inversion H13. 415 | rewrite <- H26 in H11. 416 | rewrite <- H11 in H. 417 | inversion H. 418 | reflexivity. 419 | Qed. 420 | 421 | Lemma prefix_array32_cons: forall x xs y ys s1 s2 s3 s4 t1 t2 t3 t4, 422 | (t1, t2, (t3, t4)) = ascii32_of_nat (length xs) -> 423 | (s1, s2, (s3, s4)) = ascii32_of_nat (length (x :: xs)) -> 424 | Serialized x y -> 425 | Prefix x y -> 426 | Serialized (Array32 xs) ("221" :: t1 :: t2 :: t3 :: t4 :: ys) -> 427 | Prefix (Array32 xs) ("221" :: t1 :: t2 :: t3 :: t4 :: ys) -> 428 | Prefix (Array32 (x :: xs)) ("221" :: s1 :: s2 :: s3 :: s4 :: y ++ ys). 429 | Proof. 430 | unfold Prefix. 431 | intros. 432 | destruct_serialize obj2 y0; 433 | rewrite_for y0; rewrite_for obj2; inversion H9. 434 | rewrite_for s1. 435 | rewrite_for s2. 436 | rewrite_for s3. 437 | rewrite_for s4. 438 | apply ascii32_not_O in H0; [ contradiction |]. 439 | inversion H7. 440 | split; [ simpl; omega | exact H15 ]. 441 | 442 | rewrite_for s0. 443 | rewrite_for s5. 444 | rewrite_for s6. 445 | rewrite_for s7. 446 | assert( y++ ys = y1 ++ ys1); [| rewrite_for (y++ys); reflexivity ]. 447 | rewrite <- (app_assoc y ys xs0), <- (app_assoc y1 ys1 ys0) in H20. 448 | inversion H7. 449 | inversion H8. 450 | apply (H2 x0 y1 (ys++xs0) (ys1++ys0)) in H1; auto. 451 | rewrite_for y1. 452 | apply app_same in H20. 453 | apply (H4 (Array32 xs1) ("221" :: t0 :: t5 :: t6 :: t7 :: ys1) xs0 ys0) in H3; auto. 454 | inversion H3. 455 | reflexivity. 456 | 457 | simpl. 458 | unfold ascii8 in *. 459 | rewrite <- H20. 460 | rewrite H0 in H13. 461 | apply ascii32_of_nat_eq in H13; auto. 462 | simpl in H13. 463 | inversion H13. 464 | rewrite <- H26 in H11. 465 | rewrite <- H11 in H. 466 | inversion H. 467 | reflexivity. 468 | Qed. 469 | 470 | Lemma prefix_fixmap_cons: forall x1 x2 xs y1 y2 ys b1 b2 b3 b4 b5 b6 b7 b8, 471 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 472 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length ((x1,x2)::xs)) -> 473 | Serialized x1 y1 -> Prefix x1 y1 -> 474 | Serialized x2 y2 -> Prefix x2 y2 -> 475 | Serialized (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 476 | Prefix (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 477 | Prefix (FixMap ((x1, x2) :: xs)) (Ascii b5 b6 b7 b8 false false false true :: y1 ++ y2 ++ ys). 478 | Proof. 479 | unfold Prefix. 480 | intros. 481 | destruct_serialize obj2 y; rewrite_for y; rewrite_for obj2. 482 | rewrite_for b5. 483 | rewrite_for b6. 484 | rewrite_for b7. 485 | rewrite_for b8. 486 | apply ascii8_not_O in H0; [ contradiction |]. 487 | split; [ simpl; omega |]. 488 | inversion H9. 489 | transitivity (pow 4); auto. 490 | apply pow_lt. 491 | auto. 492 | 493 | assert (y1 ++ y2 ++ ys = y0 ++ y3 ++ ys1); [| rewrite_for (y1 ++ y2 ++ ys); reflexivity ]. 494 | generalize H14; intro Happ; clear H14. 495 | replace ((y1 ++ y2 ++ ys) ++ xs0) with (y1 ++ y2 ++ ys ++ xs0) in Happ; 496 | [| repeat (rewrite app_assoc); reflexivity ]. 497 | replace ((y0 ++ y3 ++ ys1) ++ ys0) with (y0 ++ y3 ++ ys1 ++ ys0) in Happ; 498 | [| repeat (rewrite app_assoc); reflexivity ]. 499 | inversion H9. 500 | inversion H10. 501 | apply (H2 x0 y0 (y2 ++ ys ++ xs0) (y3 ++ ys1 ++ ys0))in H1; auto. 502 | rewrite_for y1. 503 | apply app_same in Happ. 504 | apply (H4 x3 y3 (ys ++ xs0) (ys1 ++ ys0)) in H3; auto. 505 | rewrite_for y3. 506 | apply app_same in Happ. 507 | apply (H6 (FixMap xs1) (Ascii b0 b9 b10 b11 false false false true :: ys1) xs0 ys0) in H5; auto. 508 | inversion H5. 509 | reflexivity. 510 | 511 | simpl. 512 | unfold ascii8 in *. 513 | rewrite <- Happ. 514 | rewrite H0 in H20. 515 | apply ascii8_of_nat_eq in H20; [ 516 | | transitivity (pow 4); [| apply pow_lt]; auto 517 | | transitivity (pow 4); [| apply pow_lt]; auto ]. 518 | simpl in H20. 519 | inversion H20. 520 | rewrite H3 in H. 521 | rewrite <- H19 in H. 522 | inversion H. 523 | reflexivity. 524 | Qed. 525 | 526 | Lemma prefix_map16_cons: forall x1 x2 xs y1 y2 ys s1 s2 t1 t2, 527 | (t1, t2) = ascii16_of_nat (length xs) -> 528 | (s1, s2) = ascii16_of_nat (length ((x1, x2) :: xs)) -> 529 | Serialized x1 y1 -> 530 | Prefix x1 y1 -> 531 | Serialized x2 y2 -> 532 | Prefix x2 y2 -> 533 | Serialized (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 534 | Prefix (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 535 | Prefix (Map16 ((x1, x2) :: xs)) ("222" :: s1 :: s2 :: y1 ++ y2 ++ ys). 536 | Proof. 537 | unfold Prefix. 538 | intros. 539 | destruct_serialize obj2 y; rewrite_for y; rewrite_for obj2. 540 | inversion H11. 541 | rewrite_for s1. 542 | rewrite_for s2. 543 | apply ascii16_not_O in H0; [ contradiction |]. 544 | inversion H9. 545 | split; [ simpl; omega | exact H20 ]. 546 | 547 | inversion H14. 548 | rewrite_for s1. 549 | rewrite_for s2. 550 | assert( y1 ++ y2 ++ ys = y0 ++ y3 ++ ys1); [| rewrite_for (y1 ++ y2 ++ ys); reflexivity ]. 551 | replace ((y1 ++ y2 ++ ys) ++ xs0) with (y1 ++ y2 ++ ys ++ xs0) in H21; 552 | [| repeat (rewrite app_assoc); reflexivity ]. 553 | replace ((y0 ++ y3 ++ ys1) ++ ys0) with (y0 ++ y3 ++ ys1 ++ ys0) in H21; 554 | [| repeat (rewrite app_assoc); reflexivity ]. 555 | inversion H9. 556 | inversion H10. 557 | apply (H2 x0 y0 (y2 ++ ys ++ xs0) (y3 ++ ys1 ++ ys0))in H1; auto. 558 | rewrite_for y1. 559 | apply app_same in H21. 560 | apply (H4 x3 y3 (ys ++ xs0) (ys1 ++ ys0)) in H3; auto. 561 | rewrite_for y3. 562 | apply app_same in H21. 563 | apply (H6 (Map16 xs1) ("222" :: t0 :: t3 :: ys1) xs0 ys0) in H5; auto. 564 | inversion H5. 565 | reflexivity. 566 | 567 | simpl. 568 | unfold ascii8 in *. 569 | rewrite <- H21. 570 | rewrite H0 in H15. 571 | apply ascii16_of_nat_eq in H15; auto. 572 | simpl in H15. 573 | inversion H15. 574 | rewrite H3 in H. 575 | rewrite <- H13 in H. 576 | inversion H. 577 | reflexivity. 578 | Qed. 579 | 580 | Lemma prefix_map32_cons : forall x1 x2 xs y1 y2 ys s1 s2 s3 s4 t1 t2 t3 t4, 581 | (t1, t2, (t3, t4)) = ascii32_of_nat (length xs) -> 582 | (s1, s2, (s3, s4)) = ascii32_of_nat (length ((x1, x2) :: xs)) -> 583 | Serialized x1 y1 -> 584 | Prefix x1 y1 -> 585 | Serialized x2 y2 -> 586 | Prefix x2 y2 -> 587 | Serialized (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 588 | Prefix (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 589 | Prefix (Map32 ((x1, x2) :: xs)) ("223" :: s1 :: s2 :: s3 :: s4 :: y1 ++ y2 ++ ys). 590 | Proof. 591 | unfold Prefix. 592 | intros. 593 | destruct_serialize obj2 y; rewrite_for y; rewrite_for obj2. 594 | inversion H11. 595 | rewrite_for s1. 596 | rewrite_for s2. 597 | rewrite_for s3. 598 | rewrite_for s4. 599 | apply ascii32_not_O in H0; [ contradiction |]. 600 | inversion H9. 601 | split; [ simpl; omega | exact H20 ]. 602 | 603 | inversion H14. 604 | rewrite_for s1. 605 | rewrite_for s2. 606 | rewrite_for s3. 607 | rewrite_for s4. 608 | generalize H23; intro Happ; clear H23. 609 | assert( y1 ++ y2 ++ ys = y0 ++ y3 ++ ys1); [| rewrite_for (y1 ++ y2 ++ ys); reflexivity ]. 610 | replace ((y1 ++ y2 ++ ys) ++ xs0) with (y1 ++ y2 ++ ys ++ xs0) in Happ; 611 | [| repeat (rewrite app_assoc); reflexivity ]. 612 | replace ((y0 ++ y3 ++ ys1) ++ ys0) with (y0 ++ y3 ++ ys1 ++ ys0) in Happ; 613 | [| repeat (rewrite app_assoc); reflexivity ]. 614 | inversion H9. 615 | inversion H10. 616 | apply (H2 x0 y0 (y2 ++ ys ++ xs0) (y3 ++ ys1 ++ ys0)) in H1; auto. 617 | rewrite_for y1. 618 | apply app_same in Happ. 619 | apply (H4 x3 y3 (ys ++ xs0) (ys1 ++ ys0)) in H3; auto. 620 | rewrite_for y3. 621 | apply app_same in Happ. 622 | apply (H6 (Map32 xs1) ("223" :: t0 :: t5 :: t6 :: t7 :: ys1) xs0 ys0) in H5; auto. 623 | inversion H5. 624 | reflexivity. 625 | 626 | simpl. 627 | unfold ascii8 in *. 628 | rewrite <- Happ. 629 | rewrite H0 in H15. 630 | apply ascii32_of_nat_eq in H15; auto. 631 | simpl in H15. 632 | inversion H15. 633 | rewrite H3 in H. 634 | rewrite <- H13 in H. 635 | inversion H. 636 | reflexivity. 637 | Qed. 638 | 639 | Hint Resolve 640 | prefix_true prefix_false 641 | prefix_nil prefix_pfixnum prefix_nfixnum 642 | prefix_uint8 prefix_uint16 prefix_uint32 prefix_uint64 643 | prefix_int8 prefix_int16 prefix_int32 prefix_int64 644 | prefix_float prefix_double 645 | prefix_raw16 prefix_raw32 646 | prefix_fixarray_nil prefix_array16_nil prefix_array32_nil 647 | prefix_fixmap_nil prefix_map16_nil prefix_map32_nil 648 | : prefix. 649 | 650 | Lemma prefix_intro: forall obj x, 651 | (Serialized obj x -> Prefix obj x)-> 652 | Prefix obj x. 653 | Proof. 654 | unfold Prefix. 655 | intros. 656 | apply H with (xs:=xs) (ys:=ys) in H1; auto. 657 | Qed. 658 | 659 | Lemma prefix : forall obj1 x, 660 | Prefix obj1 x. 661 | Proof. 662 | intros. 663 | apply prefix_intro. 664 | intro. 665 | pattern obj1,x. 666 | apply Serialized_ind; intros; auto with prefix. 667 | apply prefix_fixraw; auto. 668 | apply prefix_fixarray_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 669 | apply prefix_array16_cons with (t1:=t1) (t2:=t2); auto. 670 | apply prefix_array32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 671 | apply prefix_fixmap_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 672 | apply prefix_map16_cons with (t1:=t1) (t2:=t2); auto. 673 | apply prefix_map32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 674 | Qed. 675 | -------------------------------------------------------------------------------- /proof/ProofUtil.v: -------------------------------------------------------------------------------- 1 | Ltac rewrite_for x := 2 | match goal with 3 | | [ H : x = _ |- _ ] => rewrite H in *; clear H 4 | | [ H : _ = x |- _ ] => rewrite <- H in *; clear H 5 | end. -------------------------------------------------------------------------------- /proof/SerializeImplement.v: -------------------------------------------------------------------------------- 1 | Require Import Ascii List. 2 | Require Import ListUtil Object MultiByte Util SerializeSpec ProofUtil. 3 | 4 | Open Scope char_scope. 5 | 6 | Definition serialize_rev_list (serialize_rev: object -> list ascii8 -> list ascii8) := 7 | fix F os acc := 8 | match os with 9 | | [] => acc 10 | | o :: os => F os (serialize_rev o acc) 11 | end. 12 | 13 | Definition serialize_rev_kvs (serialize_rev: object -> list ascii8 -> list ascii8) := 14 | fix F ps acc := 15 | match ps with 16 | | [] => acc 17 | | (k,v) :: ps => F ps (serialize_rev v (serialize_rev k acc)) 18 | end. 19 | 20 | Fixpoint serialize_rev (obj : object) acc : list ascii8 := 21 | match obj with 22 | | Nil => "192" :: acc 23 | | Bool false => "194" :: acc 24 | | Bool true => "195" :: acc 25 | | PFixnum (Ascii b1 b2 b3 b4 b5 b6 b7 _) => 26 | (Ascii b1 b2 b3 b4 b5 b6 b7 false) :: acc 27 | | NFixnum (Ascii b1 b2 b3 b4 b5 _ _ _) => 28 | (Ascii b1 b2 b3 b4 b5 true true true) :: acc 29 | | Uint8 c => rev_append (list_of_ascii8 c) ("204":: acc) 30 | | Uint16 c => rev_append (list_of_ascii16 c) ("205" :: acc) 31 | | Uint32 c => rev_append (list_of_ascii32 c) ("206" :: acc) 32 | | Uint64 c => rev_append (list_of_ascii64 c) ("207" :: acc) 33 | | Int8 c => rev_append (list_of_ascii8 c) ("208" :: acc) 34 | | Int16 c => rev_append (list_of_ascii16 c) ("209" :: acc) 35 | | Int32 c => rev_append (list_of_ascii32 c) ("210" :: acc) 36 | | Int64 c => rev_append (list_of_ascii64 c) ("211" :: acc) 37 | | Float c => rev_append (list_of_ascii32 c) ("202" :: acc) 38 | | Double c => rev_append (list_of_ascii64 c) ("203" :: acc) 39 | | FixRaw xs => 40 | match ascii8_of_nat @@ length_tailrec xs with 41 | | Ascii b1 b2 b3 b4 b5 _ _ _ => 42 | rev_append xs ((Ascii b1 b2 b3 b4 b5 true false true) :: acc) 43 | end 44 | | Raw16 xs => 45 | let (s1,s2) := ascii16_of_nat @@ length_tailrec xs in 46 | rev_append xs (s2 :: s1 :: "218" :: acc) 47 | | Raw32 xs => 48 | match ascii32_of_nat @@ length_tailrec xs with 49 | | ((s1,s2),(s3,s4)) => 50 | rev_append xs (s4 :: s3 :: s2 :: s1 :: "219" :: acc) 51 | end 52 | | FixArray xs => 53 | match ascii8_of_nat @@ length_tailrec xs with 54 | | Ascii b1 b2 b3 b4 _ _ _ _ => 55 | serialize_rev_list serialize_rev xs 56 | ((Ascii b1 b2 b3 b4 true false false true) :: acc) 57 | end 58 | | Array16 xs => 59 | let (s1, s2) := ascii16_of_nat @@ length_tailrec xs in 60 | serialize_rev_list serialize_rev xs (s2 :: s1 :: "220" :: acc) 61 | | Array32 xs => 62 | match ascii32_of_nat @@ length_tailrec xs with 63 | | ((s1,s2),(s3,s4)) => 64 | serialize_rev_list serialize_rev xs (s4 :: s3 :: s2 :: s1 :: "221" :: acc) 65 | end 66 | | FixMap xs => 67 | match ascii8_of_nat @@ length_tailrec xs with 68 | | Ascii b1 b2 b3 b4 _ _ _ _ => 69 | serialize_rev_kvs serialize_rev xs 70 | ((Ascii b1 b2 b3 b4 false false false true) :: acc) 71 | end 72 | | Map16 xs => 73 | let (s1, s2) := ascii16_of_nat @@ length_tailrec xs in 74 | serialize_rev_kvs serialize_rev xs (s2 :: s1 :: "222" :: acc) 75 | | Map32 xs => 76 | match ascii32_of_nat @@ length_tailrec xs with 77 | | ((s1,s2),(s3,s4)) => 78 | serialize_rev_kvs serialize_rev xs (s4 :: s3 :: s2 :: s1 :: "223" :: acc) 79 | end 80 | end. 81 | 82 | Definition Correct obj xs := 83 | forall acc, 84 | Serialized obj xs -> 85 | serialize_rev obj acc = rev_append xs acc. 86 | 87 | Ltac straitfoward := 88 | unfold Correct; 89 | intros; 90 | simpl; 91 | reflexivity. 92 | 93 | Lemma correct_nil: 94 | Correct Nil ["192"]. 95 | Proof. 96 | straitfoward. 97 | Qed. 98 | 99 | Lemma correct_false: 100 | Correct (Bool false) ["194"]. 101 | Proof. 102 | straitfoward. 103 | Qed. 104 | 105 | Lemma correct_true: 106 | Correct (Bool true) ["195"]. 107 | Proof. 108 | straitfoward. 109 | Qed. 110 | 111 | Lemma correct_pfixnum: forall x1 x2 x3 x4 x5 x6 x7, 112 | Correct (PFixnum (Ascii x1 x2 x3 x4 x5 x6 x7 false)) 113 | [Ascii x1 x2 x3 x4 x5 x6 x7 false]. 114 | Proof. 115 | straitfoward. 116 | Qed. 117 | 118 | Lemma correct_nfixnum: forall x1 x2 x3 x4 x5, 119 | Correct (NFixnum (Ascii x1 x2 x3 x4 x5 true true true)) 120 | [Ascii x1 x2 x3 x4 x5 true true true]. 121 | Proof. 122 | straitfoward. 123 | Qed. 124 | 125 | Lemma correct_uint8 : forall c, 126 | Correct (Uint8 c) ("204"::list_of_ascii8 c). 127 | Proof. 128 | straitfoward. 129 | Qed. 130 | 131 | Lemma correct_uint16 : forall c, 132 | Correct (Uint16 c) ("205"::list_of_ascii16 c). 133 | Proof. 134 | straitfoward. 135 | Qed. 136 | 137 | Lemma correct_uint32 : forall c, 138 | Correct (Uint32 c) ("206"::list_of_ascii32 c). 139 | Proof. 140 | straitfoward. 141 | Qed. 142 | 143 | Lemma correct_uint64 : forall c, 144 | Correct (Uint64 c) ("207"::list_of_ascii64 c). 145 | Proof. 146 | straitfoward. 147 | Qed. 148 | 149 | Lemma correct_int8 : forall c, 150 | Correct (Int8 c) ("208"::list_of_ascii8 c). 151 | Proof. 152 | straitfoward. 153 | Qed. 154 | 155 | Lemma correct_int16 : forall c, 156 | Correct (Int16 c) ("209"::list_of_ascii16 c). 157 | Proof. 158 | straitfoward. 159 | Qed. 160 | 161 | Lemma correct_int32 : forall c, 162 | Correct (Int32 c) ("210"::list_of_ascii32 c). 163 | Proof. 164 | straitfoward. 165 | Qed. 166 | 167 | Lemma correct_int64 : forall c, 168 | Correct (Int64 c) ("211"::list_of_ascii64 c). 169 | Proof. 170 | straitfoward. 171 | Qed. 172 | 173 | Lemma correct_float : forall c, 174 | Correct (Float c) ("202"::list_of_ascii32 c). 175 | Proof. 176 | straitfoward. 177 | Qed. 178 | 179 | Lemma correct_double : forall c, 180 | Correct (Double c) ("203"::list_of_ascii64 c). 181 | Proof. 182 | straitfoward. 183 | Qed. 184 | 185 | Lemma correct_fixraw : forall cs b1 b2 b3 b4 b5, 186 | Ascii b1 b2 b3 b4 b5 false false false = ascii8_of_nat (length cs) -> 187 | Correct (FixRaw cs) ((Ascii b1 b2 b3 b4 b5 true false true)::cs). 188 | Proof. 189 | unfold Correct. 190 | intros. 191 | inversion H0. 192 | simpl. 193 | rewrite length_tailrec_equiv. 194 | rewrite_for (ascii8_of_nat (length cs)). 195 | reflexivity. 196 | Qed. 197 | 198 | Lemma correct_raw16: forall cs s1 s2, 199 | (s1,s2) = ascii16_of_nat (length cs) -> 200 | Correct (Raw16 cs) ("218"::s1::s2::cs). 201 | Proof. 202 | unfold Correct. 203 | intros. 204 | inversion H0. 205 | simpl. 206 | rewrite length_tailrec_equiv. 207 | rewrite_for (ascii16_of_nat (length cs)). 208 | reflexivity. 209 | Qed. 210 | 211 | Lemma correct_raw32 : forall cs s1 s2 s3 s4, 212 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length cs) -> 213 | Correct (Raw32 cs) ("219"::s1::s2::s3::s4::cs). 214 | Proof. 215 | unfold Correct. 216 | intros. 217 | inversion H0. 218 | simpl. 219 | rewrite length_tailrec_equiv. 220 | rewrite_for (ascii32_of_nat (length cs)). 221 | reflexivity. 222 | Qed. 223 | 224 | Lemma correct_fixarray_nil: 225 | Correct (FixArray []) ["144"]. 226 | Proof. 227 | straitfoward. 228 | Qed. 229 | 230 | Lemma correct_array16_nil: 231 | Correct (Array16 []) ["220"; "000"; "000"]. 232 | Proof. 233 | unfold Correct. 234 | intros. 235 | simpl. 236 | rewrite <- ascii8_of_nat_O. 237 | reflexivity. 238 | Qed. 239 | 240 | Lemma correct_array32_nil: 241 | Correct (Array32 []) ["221"; "000"; "000";"000"; "000"]. 242 | Proof. 243 | unfold Correct. 244 | intros. 245 | simpl. 246 | rewrite <- ascii8_of_nat_O. 247 | reflexivity. 248 | Qed. 249 | 250 | Lemma correct_fixmap_nil: 251 | Correct (FixMap []) ["128"]. 252 | Proof. 253 | straitfoward. 254 | Qed. 255 | 256 | Lemma correct_map16_nil: 257 | Correct (Map16 []) ["222"; "000"; "000"]. 258 | Proof. 259 | unfold Correct. 260 | intros. 261 | simpl. 262 | rewrite <- ascii8_of_nat_O. 263 | reflexivity. 264 | Qed. 265 | 266 | Lemma correct_map32_nil: 267 | Correct (Map32 []) ["223"; "000"; "000";"000"; "000"]. 268 | Proof. 269 | unfold Correct. 270 | intros. 271 | simpl. 272 | rewrite <- ascii8_of_nat_O. 273 | reflexivity. 274 | Qed. 275 | 276 | Lemma Prepending_serialize_rev_list': forall f os, (Forall (fun o => Prepending (f o))) os -> 277 | Prepending (serialize_rev_list f os). 278 | Proof. 279 | unfold Prepending. intros * H. 280 | induction H; [reflexivity|]. 281 | intros ys zs. simpl. rewrite H. apply IHForall. 282 | Qed. 283 | 284 | Lemma Prepending_serialize_rev_kvs': forall f ps, 285 | (Forall (fun p => Prepending (f (fst p)) /\ Prepending (f (snd p)))) ps -> 286 | Prepending (serialize_rev_kvs f ps). 287 | Proof. 288 | unfold Prepending. intros * H. 289 | induction H as [|[x1 x2] ? [H1 H2]]; [reflexivity|]. 290 | intros ys zs. simpl. rewrite H1, H2. apply IHForall. 291 | Qed. 292 | 293 | Lemma Prepending_serialize_rev: forall o, 294 | Prepending (serialize_rev o). 295 | Proof. 296 | unfold Prepending. 297 | intros. 298 | generalize ys zs; clear ys zs. 299 | induction o using object_ind'; intros ys zs; simpl. 300 | - destruct x; reflexivity. 301 | - reflexivity. 302 | - destruct x. reflexivity. 303 | - destruct x. reflexivity. 304 | - reflexivity. 305 | - rewrite <-Prepending_rev_append. reflexivity. 306 | - rewrite <-Prepending_rev_append. reflexivity. 307 | - rewrite <-Prepending_rev_append. reflexivity. 308 | - reflexivity. 309 | - rewrite <-Prepending_rev_append. reflexivity. 310 | - rewrite <-Prepending_rev_append. reflexivity. 311 | - rewrite <-Prepending_rev_append. reflexivity. 312 | - rewrite <-Prepending_rev_append. reflexivity. 313 | - rewrite <-Prepending_rev_append. reflexivity. 314 | - destruct (ascii8_of_nat (length_tailrec x)). rewrite <-Prepending_rev_append. reflexivity. 315 | - destruct (ascii16_of_nat (length_tailrec x)). rewrite <-Prepending_rev_append. reflexivity. 316 | - destruct (ascii32_of_nat (length_tailrec x)) as [[? ?] [? ?]]. 317 | rewrite <-Prepending_rev_append. reflexivity. 318 | - destruct (ascii8_of_nat (length_tailrec os)) as [b1 b2 b3 b4 b5 b6 b7 b8]. 319 | rewrite app_comm_cons. 320 | generalize ((Ascii b1 b2 b3 b4 true false false true :: ys)); intros. 321 | apply (Prepending_serialize_rev_list' serialize_rev). 322 | apply H. 323 | - destruct (ascii16_of_nat (length_tailrec os)) as [s1 s2]. 324 | rewrite !app_comm_cons. 325 | generalize ((s2 :: s1 :: "220" :: ys)); intros. 326 | apply (Prepending_serialize_rev_list' serialize_rev). 327 | apply H. 328 | - destruct (ascii32_of_nat (length_tailrec os)) as [[s1 s2] [s3 s4]]. 329 | rewrite !app_comm_cons. 330 | generalize ((s4 :: s3 :: s2 :: s1 :: "221" :: ys)); intros. 331 | apply (Prepending_serialize_rev_list' serialize_rev). 332 | apply H. 333 | - destruct (ascii8_of_nat (length_tailrec ps)) as [b1 b2 b3 b4 b5 b6 b7 b8]. 334 | rewrite app_comm_cons. 335 | generalize ((Ascii b1 b2 b3 b4 false false false true :: ys)); intros. 336 | apply (Prepending_serialize_rev_kvs' serialize_rev). 337 | apply H. 338 | - destruct (ascii16_of_nat (length_tailrec ps)) as [s1 s2]. 339 | rewrite !app_comm_cons. 340 | generalize ((s2 :: s1 :: "222" :: ys)); intros. 341 | apply (Prepending_serialize_rev_kvs' serialize_rev). 342 | apply H. 343 | - destruct (ascii32_of_nat (length_tailrec ps)) as [[s1 s2] [s3 s4]]. 344 | rewrite !app_comm_cons. 345 | generalize ((s4 :: s3 :: s2 :: s1 :: "223" :: ys)); intros. 346 | apply (Prepending_serialize_rev_kvs' serialize_rev). 347 | apply H. 348 | Qed. 349 | 350 | Lemma Prepending_serialize_rev_list: forall os, 351 | Prepending (serialize_rev_list serialize_rev os). 352 | Proof. 353 | intros. 354 | apply Prepending_serialize_rev_list'. 355 | apply Forall_forall. 356 | intros. 357 | apply Prepending_serialize_rev. 358 | Qed. 359 | 360 | Lemma Prepending_serialize_rev_kvs: forall ps, 361 | Prepending (serialize_rev_kvs serialize_rev ps). 362 | Proof. 363 | intros. 364 | apply Prepending_serialize_rev_kvs'. 365 | apply Forall_forall. 366 | intros. 367 | split; apply Prepending_serialize_rev. 368 | Qed. 369 | 370 | 371 | Lemma correct_fixarray_cons: forall x xs y ys b1 b2 b3 b4 b5 b6 b7 b8, 372 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 373 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length (x::xs)) -> 374 | Serialized x y -> 375 | Correct x y -> 376 | Serialized (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 377 | Correct (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 378 | Correct (FixArray (x :: xs)) ((Ascii b5 b6 b7 b8 true false false true)::y ++ ys). 379 | Proof. 380 | unfold Correct. 381 | intros. 382 | simpl in *. 383 | rewrite length_tailrec_equiv in *. 384 | simpl. 385 | rewrite_for (ascii8_of_nat (S (length xs))). 386 | eapply H2 in H1. 387 | apply (H4 acc) in H3. 388 | rewrite_for (ascii8_of_nat (length xs)). 389 | rewrite rev_append_app_left. 390 | rewrite <-H1. 391 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)). 392 | rewrite (Prepending_nil (serialize_rev_list serialize_rev xs)); [|apply Prepending_serialize_rev_list]. 393 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)) in H3. 394 | rewrite (Prepending_nil (serialize_rev_list serialize_rev xs)) in H3; [|apply Prepending_serialize_rev_list]. 395 | apply app_inv_tail in H3. 396 | rewrite H3. 397 | reflexivity. 398 | Qed. 399 | 400 | Lemma correct_array16_cons: forall x xs t1 t2 s1 s2 y ys, 401 | (t1, t2) = ascii16_of_nat (length xs) -> 402 | (s1, s2) = ascii16_of_nat (length (x :: xs)) -> 403 | Serialized x y -> 404 | (Serialized x y -> Correct x y) -> 405 | Serialized (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 406 | (Serialized (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 407 | Correct (Array16 xs) ("220" :: t1 :: t2 :: ys)) -> 408 | Correct (Array16 (x :: xs)) ("220" :: s1 :: s2 :: y ++ ys). 409 | Proof. 410 | unfold Correct. 411 | intros. 412 | simpl in *. 413 | rewrite length_tailrec_equiv in *. 414 | simpl. 415 | rewrite_for (ascii16_of_nat (S (length xs))). 416 | eapply H2 in H1; auto. 417 | specialize (H4 H3 acc). 418 | rewrite_for (ascii16_of_nat (length xs)). 419 | rewrite rev_append_app_left. 420 | rewrite <-H1. 421 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)). 422 | rewrite (Prepending_nil (serialize_rev_list serialize_rev xs)); [|apply Prepending_serialize_rev_list]. 423 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)) in H4. 424 | rewrite (Prepending_nil (serialize_rev_list serialize_rev xs)) in H4; [|apply Prepending_serialize_rev_list]. 425 | apply app_inv_tail in H4; auto. 426 | rewrite H4. 427 | reflexivity. 428 | Qed. 429 | 430 | Lemma correct_array32_cons: forall x xs y ys s1 s2 s3 s4 t1 t2 t3 t4, 431 | ((t1,t2),(t3,t4)) = ascii32_of_nat (length xs) -> 432 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length (x::xs)) -> 433 | Serialized x y -> 434 | (Serialized x y -> Correct x y) -> 435 | Serialized (Array32 xs) ("221"::t1::t2::t3::t4::ys) -> 436 | (Serialized (Array32 xs) ("221"::t1::t2::t3::t4::ys) -> Correct (Array32 xs) ("221"::t1::t2::t3::t4::ys)) -> 437 | Correct (Array32 (x::xs)) ("221"::s1::s2::s3::s4::y ++ ys). 438 | Proof. 439 | unfold Correct. 440 | intros. 441 | simpl in *. 442 | rewrite length_tailrec_equiv in *. 443 | simpl. 444 | rewrite_for (ascii32_of_nat (S (length xs))). 445 | eapply H2 in H1; auto. 446 | specialize (H4 H3 acc). 447 | rewrite_for (ascii32_of_nat (length xs)). 448 | rewrite rev_append_app_left. 449 | rewrite <-H1. 450 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)). 451 | rewrite (Prepending_nil (serialize_rev_list serialize_rev xs)); [|apply Prepending_serialize_rev_list]. 452 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)) in H4. 453 | rewrite (Prepending_nil (serialize_rev_list serialize_rev xs)) in H4; [|apply Prepending_serialize_rev_list]. 454 | apply app_inv_tail in H4; auto. 455 | rewrite H4. 456 | reflexivity. 457 | Qed. 458 | 459 | Lemma correct_fixmap_cons: forall x1 x2 xs y1 y2 ys b1 b2 b3 b4 b5 b6 b7 b8, 460 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 461 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length ((x1,x2)::xs)) -> 462 | Serialized x1 y1 -> Correct x1 y1 -> 463 | Serialized x2 y2 -> Correct x2 y2 -> 464 | Serialized (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 465 | Correct (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 466 | Correct (FixMap ((x1, x2) :: xs)) (Ascii b5 b6 b7 b8 false false false true :: y1 ++ y2 ++ ys). 467 | Proof. 468 | unfold Correct. 469 | intros. 470 | simpl in *. 471 | rewrite length_tailrec_equiv in *. 472 | simpl. 473 | rewrite_for (ascii8_of_nat (S (length xs))). 474 | eapply H2 in H1. 475 | eapply H4 in H3. 476 | apply (H6 acc) in H5. 477 | rewrite_for (ascii8_of_nat (length xs)). 478 | do 2 rewrite rev_append_app_left. 479 | rewrite <-H1, <-H3. 480 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)). 481 | rewrite (Prepending_nil (serialize_rev_kvs serialize_rev xs)); [|apply Prepending_serialize_rev_kvs]. 482 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)) in H5. 483 | rewrite (Prepending_nil (serialize_rev_kvs serialize_rev xs)) in H5; [|apply Prepending_serialize_rev_kvs]. 484 | apply app_inv_tail in H5. 485 | rewrite H5. 486 | reflexivity. 487 | Qed. 488 | 489 | Lemma correct_map16_cons: forall x1 x2 xs y1 y2 ys s1 s2 t1 t2, 490 | (t1, t2) = ascii16_of_nat (length xs) -> 491 | (s1, s2) = ascii16_of_nat (length ((x1, x2) :: xs)) -> 492 | Serialized x1 y1 -> 493 | Correct x1 y1 -> 494 | Serialized x2 y2 -> 495 | Correct x2 y2 -> 496 | Serialized (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 497 | Correct (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 498 | Correct (Map16 ((x1, x2) :: xs)) ("222" :: s1 :: s2 :: y1 ++ y2 ++ ys). 499 | Proof. 500 | unfold Correct. 501 | intros. 502 | simpl in *. 503 | rewrite length_tailrec_equiv in *. 504 | simpl. 505 | rewrite_for (ascii16_of_nat (S (length xs))). 506 | eapply H2 in H1. 507 | eapply H4 in H3. 508 | apply (H6 acc) in H5. 509 | rewrite_for (ascii16_of_nat (length xs)). 510 | do 2 rewrite rev_append_app_left. 511 | rewrite <-H1, <-H3. 512 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)). 513 | rewrite (Prepending_nil (serialize_rev_kvs serialize_rev xs)); [|apply Prepending_serialize_rev_kvs]. 514 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)) in H5. 515 | rewrite (Prepending_nil (serialize_rev_kvs serialize_rev xs)) in H5; [|apply Prepending_serialize_rev_kvs]. 516 | apply app_inv_tail in H5. 517 | rewrite H5. 518 | reflexivity. 519 | Qed. 520 | 521 | Lemma correct_map32_cons : forall x1 x2 xs y1 y2 ys s1 s2 s3 s4 t1 t2 t3 t4, 522 | (t1, t2, (t3, t4)) = ascii32_of_nat (length xs) -> 523 | (s1, s2, (s3, s4)) = ascii32_of_nat (length ((x1, x2) :: xs)) -> 524 | Serialized x1 y1 -> 525 | Correct x1 y1 -> 526 | Serialized x2 y2 -> 527 | Correct x2 y2 -> 528 | Serialized (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 529 | Correct (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 530 | Correct (Map32 ((x1, x2) :: xs)) ("223" :: s1 :: s2 :: s3 :: s4 :: y1 ++ y2 ++ ys). 531 | Proof. 532 | unfold Correct. 533 | intros. 534 | simpl in *. 535 | rewrite length_tailrec_equiv in *. 536 | simpl. 537 | rewrite_for (ascii32_of_nat (S (length xs))). 538 | eapply H2 in H1. 539 | eapply H4 in H3. 540 | apply (H6 acc) in H5. 541 | rewrite <-H in *. 542 | do 2 rewrite rev_append_app_left. 543 | rewrite <-H1, <-H3. 544 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)). 545 | rewrite (Prepending_nil (serialize_rev_kvs serialize_rev xs)); [|apply Prepending_serialize_rev_kvs]. 546 | rewrite (Prepending_nil _ (Prepending_rev_append _ _)) in H5. 547 | rewrite (Prepending_nil (serialize_rev_kvs serialize_rev xs)) in H5; [|apply Prepending_serialize_rev_kvs]. 548 | apply app_inv_tail in H5. 549 | rewrite H5. 550 | reflexivity. 551 | Qed. 552 | 553 | Lemma correct_intro : forall obj xs, 554 | (Serialized obj xs -> Correct obj xs) -> 555 | Correct obj xs. 556 | Proof. 557 | unfold Correct. 558 | intros. 559 | auto. 560 | Qed. 561 | 562 | Hint Resolve 563 | correct_true correct_false 564 | correct_nil correct_pfixnum correct_nfixnum 565 | correct_uint8 correct_uint16 correct_uint32 correct_uint64 566 | correct_int8 correct_int16 correct_int32 correct_int64 567 | correct_float correct_double 568 | correct_raw16 correct_raw32 569 | correct_fixarray_nil correct_array16_nil correct_array32_nil 570 | correct_fixmap_nil correct_map16_nil correct_map32_nil 571 | : correct. 572 | 573 | 574 | Theorem serialize_correct : forall obj xs, 575 | Correct obj xs. 576 | Proof. 577 | intros. 578 | apply correct_intro. 579 | intro. 580 | pattern obj,xs. 581 | apply Serialized_ind; intros; auto with correct. 582 | apply correct_fixraw; auto. 583 | apply correct_fixarray_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 584 | apply correct_array16_cons with (t1:=t1) (t2:=t2); auto. 585 | apply correct_array32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 586 | apply correct_fixmap_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 587 | apply correct_map16_cons with (t1:=t1) (t2:=t2); auto. 588 | apply correct_map32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 589 | Qed. 590 | 591 | -------------------------------------------------------------------------------- /proof/SerializeSpec.v: -------------------------------------------------------------------------------- 1 | Require Import List Ascii. 2 | Require Import MultiByte Object ListUtil. 3 | 4 | Open Scope list_scope. 5 | Open Scope char_scope. 6 | 7 | Inductive Serialized : object -> list ascii8 -> Prop := 8 | | SNil : 9 | Serialized Nil ["192"] 10 | | STrue : 11 | Serialized (Bool true) ["195"] 12 | | SFalse : 13 | Serialized (Bool false) ["194"] 14 | | SPFixnum : forall x1 x2 x3 x4 x5 x6 x7, 15 | Serialized (PFixnum (Ascii x1 x2 x3 x4 x5 x6 x7 false)) 16 | [Ascii x1 x2 x3 x4 x5 x6 x7 false] 17 | | SNFixnum : forall x1 x2 x3 x4 x5, 18 | Serialized (NFixnum (Ascii x1 x2 x3 x4 x5 true true true)) 19 | [Ascii x1 x2 x3 x4 x5 true true true] 20 | | SUint8 : forall c, 21 | Serialized (Uint8 c) ("204"::list_of_ascii8 c) 22 | | SUint16 : forall c, 23 | Serialized (Uint16 c) ("205"::list_of_ascii16 c) 24 | | SUint32 : forall c, 25 | Serialized (Uint32 c) ("206"::list_of_ascii32 c) 26 | | SUint64 : forall c, 27 | Serialized (Uint64 c) ("207"::list_of_ascii64 c) 28 | | SInt8 : forall c, 29 | Serialized (Int8 c) ("208"::list_of_ascii8 c) 30 | | SInt16 : forall c, 31 | Serialized (Int16 c) ("209"::list_of_ascii16 c) 32 | | SInt32 : forall c, 33 | Serialized (Int32 c) ("210"::list_of_ascii32 c) 34 | | SInt64 : forall c, 35 | Serialized (Int64 c) ("211"::list_of_ascii64 c) 36 | | SFloat : forall c, 37 | Serialized (Float c) ("202"::list_of_ascii32 c) 38 | | SDouble : forall c, 39 | Serialized (Double c) ("203"::list_of_ascii64 c) 40 | | SFixRaw : forall cs b1 b2 b3 b4 b5, 41 | Ascii b1 b2 b3 b4 b5 false false false = ascii8_of_nat (length cs) -> 42 | Serialized (FixRaw cs) ((Ascii b1 b2 b3 b4 b5 true false true)::cs) 43 | | SRaw16 : forall cs s1 s2, 44 | (s1,s2) = ascii16_of_nat (length cs) -> 45 | Serialized (Raw16 cs) ("218"::s1::s2::cs) 46 | | SRaw32 : forall cs s1 s2 s3 s4, 47 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length cs) -> 48 | Serialized (Raw32 cs) ("219"::s1::s2::s3::s4::cs) 49 | | SFixArrayNil : 50 | Serialized (FixArray []) ["144"] 51 | | SFixArrayCons : forall x xs y ys b1 b2 b3 b4 b5 b6 b7 b8, 52 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 53 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length (x::xs)) -> 54 | Serialized x y -> 55 | Serialized (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 56 | Serialized (FixArray (x::xs)) ((Ascii b5 b6 b7 b8 true false false true)::y ++ ys) 57 | | SArray16Nil : 58 | Serialized (Array16 []) ["220"; "000"; "000"] 59 | | SArray16Cons : forall x xs y ys s1 s2 t1 t2, 60 | (t1,t2) = ascii16_of_nat (length xs) -> 61 | (s1,s2) = ascii16_of_nat (length (x::xs)) -> 62 | Serialized x y -> 63 | Serialized (Array16 xs) ("220"::t1::t2::ys) -> 64 | Serialized (Array16 (x::xs)) ("220"::s1::s2::y ++ ys) 65 | | SArray32Nil : 66 | Serialized (Array32 []) ["221"; "000"; "000";"000"; "000"] 67 | | SArray32Cons : forall x xs y ys s1 s2 s3 s4 t1 t2 t3 t4, 68 | ((t1,t2),(t3,t4)) = ascii32_of_nat (length xs) -> 69 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length (x::xs)) -> 70 | Serialized x y -> 71 | Serialized (Array32 xs) ("221"::t1::t2::t3::t4::ys) -> 72 | Serialized (Array32 (x::xs)) ("221"::s1::s2::s3::s4::y ++ ys) 73 | | SFixMapNil : 74 | Serialized (FixMap []) ["128"] 75 | | SFixMapCons : forall x1 x2 xs y1 y2 ys b1 b2 b3 b4 b5 b6 b7 b8, 76 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 77 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length ((x1,x2)::xs)) -> 78 | Serialized x1 y1 -> 79 | Serialized x2 y2 -> 80 | Serialized (FixMap xs) ((Ascii b1 b2 b3 b4 false false false true)::ys) -> 81 | Serialized (FixMap ((x1,x2)::xs)) ((Ascii b5 b6 b7 b8 false false false true)::y1 ++ y2 ++ ys) 82 | | SMap16Nil : 83 | Serialized (Map16 []) ["222"; "000"; "000"] 84 | | SMap16Cons : forall x1 x2 xs y1 y2 ys s1 s2 t1 t2, 85 | (t1,t2) = ascii16_of_nat (length xs) -> 86 | (s1,s2) = ascii16_of_nat (length ((x1,x2)::xs)) -> 87 | Serialized x1 y1 -> 88 | Serialized x2 y2 -> 89 | Serialized (Map16 xs) ("222"::t1::t2::ys) -> 90 | Serialized (Map16 ((x1,x2)::xs)) ("222"::s1::s2::y1 ++ y2 ++ ys) 91 | | SMap32Nil : 92 | Serialized (Map32 []) ["223"; "000"; "000";"000"; "000"] 93 | | SMap32Cons : forall x1 x2 xs y1 y2 ys s1 s2 s3 s4 t1 t2 t3 t4, 94 | ((t1,t2),(t3,t4)) = ascii32_of_nat (length xs) -> 95 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length ((x1,x2)::xs)) -> 96 | Serialized x1 y1 -> 97 | Serialized x2 y2 -> 98 | Serialized (Map32 xs) ("223"::t1::t2::t3::t4::ys) -> 99 | Serialized (Map32 ((x1,x2)::xs)) ("223"::s1::s2::s3::s4::y1 ++ y2 ++ ys). 100 | -------------------------------------------------------------------------------- /proof/SerializedList.v: -------------------------------------------------------------------------------- 1 | Require Import Ascii List. 2 | Require Import ListUtil Object MultiByte Util SerializeSpec Pow. 3 | 4 | Open Scope char_scope. 5 | 6 | Definition lift P (o : object) (b : list ascii) := forall os bs, 7 | P os bs -> P (o::os) (b ++ bs). 8 | 9 | Inductive SerializedList : list object -> list ascii8 -> Prop := 10 | | SLbot : 11 | SerializedList [] [] 12 | | SLNil: 13 | lift SerializedList Nil ["192"] 14 | | SLTrue : 15 | lift SerializedList (Bool true) ["195"] 16 | | SLFalse : 17 | lift SerializedList (Bool false) ["194"] 18 | | SLPFixnum : forall x1 x2 x3 x4 x5 x6 x7, 19 | lift SerializedList (PFixnum (Ascii x1 x2 x3 x4 x5 x6 x7 false)) 20 | [Ascii x1 x2 x3 x4 x5 x6 x7 false] 21 | | SLNFixnum : forall x1 x2 x3 x4 x5, 22 | lift SerializedList (NFixnum (Ascii x1 x2 x3 x4 x5 true true true)) 23 | [Ascii x1 x2 x3 x4 x5 true true true] 24 | | SLUint8 : forall c, 25 | lift SerializedList (Uint8 c) ("204" :: list_of_ascii8 c) 26 | | SLUint16 : forall c, 27 | lift SerializedList (Uint16 c) ("205" :: list_of_ascii16 c) 28 | | SLUint32 : forall c, 29 | lift SerializedList (Uint32 c) ("206" :: list_of_ascii32 c) 30 | | SLUint64 : forall c, 31 | lift SerializedList (Uint64 c) ("207" :: list_of_ascii64 c) 32 | | SLInt8 : forall c, 33 | lift SerializedList (Int8 c) ("208" :: list_of_ascii8 c) 34 | | SLInt16 : forall c, 35 | lift SerializedList (Int16 c) ("209" :: list_of_ascii16 c) 36 | | SLInt32 : forall c, 37 | lift SerializedList (Int32 c) ("210" :: list_of_ascii32 c) 38 | | SLInt64 : forall c, 39 | lift SerializedList (Int64 c) ("211" :: list_of_ascii64 c) 40 | | SLFloat : forall c, 41 | lift SerializedList (Float c) ("202" :: list_of_ascii32 c) 42 | | SLDouble : forall c, 43 | lift SerializedList (Double c) ("203" :: list_of_ascii64 c) 44 | | SLFixRaw : forall cs b1 b2 b3 b4 b5, 45 | Ascii b1 b2 b3 b4 b5 false false false = ascii8_of_nat (length cs) -> 46 | List.length cs < pow 5 -> 47 | lift SerializedList (FixRaw cs) ((Ascii b1 b2 b3 b4 b5 true false true) :: cs) 48 | | SLRaw16 : forall cs s1 s2, 49 | (s1,s2) = ascii16_of_nat (length cs) -> 50 | List.length cs < pow 16 -> 51 | lift SerializedList (Raw16 cs) ("218" :: s1 :: s2 :: cs) 52 | | SLRaw32 : forall cs s1 s2 s3 s4, 53 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length cs) -> 54 | List.length cs < pow 32 -> 55 | lift SerializedList (Raw32 cs) ("219" :: s1 :: s2 :: s3 :: s4 :: cs) 56 | | SLFixArray : forall os n b1 b2 b3 b4 xs ys bs, 57 | SerializedList os bs -> 58 | (xs,ys) = split_at n os -> 59 | n < pow 4 -> 60 | (Ascii b1 b2 b3 b4 false false false false) = ascii8_of_nat n -> 61 | SerializedList ((FixArray xs) :: ys) ((Ascii b1 b2 b3 b4 true false false true) :: bs) 62 | | SLArray16 : forall os n xs ys bs s1 s2, 63 | SerializedList os bs -> 64 | (xs,ys) = split_at n os -> 65 | n < pow 16 -> 66 | (s1,s2) = ascii16_of_nat n -> 67 | SerializedList ((Array16 xs)::ys) ("220" :: s1 :: s2 :: bs) 68 | | SLArray32 : forall os n xs ys bs s1 s2 s3 s4, 69 | SerializedList os bs -> 70 | (xs,ys) = split_at n os -> 71 | n < pow 32 -> 72 | ((s1,s2),(s3,s4)) = ascii32_of_nat n -> 73 | SerializedList ((Array32 xs)::ys) ("221" :: s1 :: s2 :: s3 :: s4 :: bs) 74 | | SLFixMap : forall os n b1 b2 b3 b4 xs ys bs, 75 | SerializedList os bs -> 76 | (xs,ys) = split_at (2 * n) os -> 77 | List.length xs = 2 * n -> 78 | n < pow 4 -> 79 | (Ascii b1 b2 b3 b4 false false false false) = ascii8_of_nat n -> 80 | SerializedList ((FixMap (pair xs)) :: ys) ((Ascii b1 b2 b3 b4 false false false true) :: bs) 81 | | SLMap16 : forall os n xs ys bs s1 s2, 82 | SerializedList os bs -> 83 | (xs,ys) = split_at (2 * n) os -> 84 | List.length xs = 2 * n -> 85 | n < pow 16 -> 86 | (s1,s2) = ascii16_of_nat n -> 87 | SerializedList ((Map16 (pair xs))::ys) ("222" :: s1 :: s2 :: bs) 88 | | SLMap32 : forall os n xs ys bs s1 s2 s3 s4, 89 | SerializedList os bs -> 90 | (xs,ys) = split_at (2 * n) os -> 91 | List.length xs = 2 * n -> 92 | n < pow 32 -> 93 | ((s1,s2),(s3,s4)) = ascii32_of_nat n -> 94 | SerializedList ((Map32 (pair xs))::ys) ("223" :: s1 :: s2 :: s3 :: s4 :: bs). 95 | 96 | Lemma app_cons: forall A (xs ys zs : list A) x, 97 | x :: (xs ++ ys) ++ zs = x :: (xs ++ ys ++ zs). 98 | Proof. 99 | induction xs; intros; simpl; auto. 100 | rewrite (IHxs ys zs a). 101 | reflexivity. 102 | Qed. 103 | 104 | Definition Soundness o bs := forall os bs', 105 | Serialized o bs -> 106 | Valid o -> 107 | SerializedList os bs' -> 108 | SerializedList (o :: os) (bs ++ bs'). 109 | 110 | Ltac straitfoward P := 111 | intros; 112 | unfold Soundness; 113 | intros os bs' Hs Hv Hsl; 114 | apply P; 115 | auto. 116 | 117 | Lemma soundness_nil: 118 | Soundness Nil ["192"]. 119 | Proof. 120 | straitfoward SLNil. 121 | Qed. 122 | 123 | Lemma soundness_false: 124 | Soundness (Bool false) ["194"]. 125 | Proof. 126 | straitfoward SLFalse. 127 | Qed. 128 | 129 | Lemma soundness_true: 130 | Soundness (Bool true) ["195"]. 131 | Proof. 132 | straitfoward SLTrue. 133 | Qed. 134 | 135 | Lemma soundness_pfixnum: forall x1 x2 x3 x4 x5 x6 x7, 136 | Soundness (PFixnum (Ascii x1 x2 x3 x4 x5 x6 x7 false)) 137 | [Ascii x1 x2 x3 x4 x5 x6 x7 false]. 138 | Proof. 139 | straitfoward SLPFixnum. 140 | Qed. 141 | 142 | Lemma soundness_nfixnum: forall x1 x2 x3 x4 x5, 143 | Soundness (NFixnum (Ascii x1 x2 x3 x4 x5 true true true)) 144 | [Ascii x1 x2 x3 x4 x5 true true true]. 145 | Proof. 146 | straitfoward SLNFixnum. 147 | Qed. 148 | 149 | Lemma soundness_uint8 : forall c, 150 | Soundness (Uint8 c) ("204"::list_of_ascii8 c). 151 | Proof. 152 | straitfoward SLUint8. 153 | Qed. 154 | 155 | Lemma soundness_uint16 : forall c, 156 | Soundness (Uint16 c) ("205"::list_of_ascii16 c). 157 | Proof. 158 | straitfoward SLUint16. 159 | Qed. 160 | 161 | Lemma soundness_uint32 : forall c, 162 | Soundness (Uint32 c) ("206"::list_of_ascii32 c). 163 | Proof. 164 | straitfoward SLUint32. 165 | Qed. 166 | 167 | Lemma soundness_uint64 : forall c, 168 | Soundness (Uint64 c) ("207"::list_of_ascii64 c). 169 | Proof. 170 | straitfoward SLUint64. 171 | Qed. 172 | 173 | Lemma soundness_int8 : forall c, 174 | Soundness (Int8 c) ("208"::list_of_ascii8 c). 175 | Proof. 176 | straitfoward SLInt8. 177 | Qed. 178 | 179 | Lemma soundness_int16 : forall c, 180 | Soundness (Int16 c) ("209"::list_of_ascii16 c). 181 | Proof. 182 | straitfoward SLInt16. 183 | Qed. 184 | 185 | Lemma soundness_int32 : forall c, 186 | Soundness (Int32 c) ("210"::list_of_ascii32 c). 187 | Proof. 188 | straitfoward SLInt32. 189 | Qed. 190 | 191 | Lemma soundness_int64 : forall c, 192 | Soundness (Int64 c) ("211"::list_of_ascii64 c). 193 | Proof. 194 | straitfoward SLInt64. 195 | Qed. 196 | 197 | Lemma soundness_float : forall c, 198 | Soundness (Float c) ("202"::list_of_ascii32 c). 199 | Proof. 200 | straitfoward SLFloat. 201 | Qed. 202 | 203 | Lemma soundness_double : forall c, 204 | Soundness (Double c) ("203"::list_of_ascii64 c). 205 | Proof. 206 | straitfoward SLDouble. 207 | Qed. 208 | 209 | Lemma soundness_fixraw : forall cs b1 b2 b3 b4 b5, 210 | Ascii b1 b2 b3 b4 b5 false false false = ascii8_of_nat (length cs) -> 211 | Soundness (FixRaw cs) ((Ascii b1 b2 b3 b4 b5 true false true)::cs). 212 | Proof. 213 | straitfoward SLFixRaw. 214 | inversion Hv. 215 | assumption. 216 | Qed. 217 | 218 | Lemma soundness_raw16: forall cs s1 s2, 219 | (s1,s2) = ascii16_of_nat (length cs) -> 220 | Soundness (Raw16 cs) ("218"::s1::s2::cs). 221 | Proof. 222 | straitfoward SLRaw16. 223 | inversion Hv. 224 | assumption. 225 | Qed. 226 | 227 | Lemma soundness_raw32 : forall cs s1 s2 s3 s4, 228 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length cs) -> 229 | Soundness (Raw32 cs) ("219"::s1::s2::s3::s4::cs). 230 | Proof. 231 | straitfoward SLRaw32. 232 | inversion Hv. 233 | assumption. 234 | Qed. 235 | 236 | Lemma soundness_fixarray_nil : 237 | Soundness (FixArray []) ["144"]. 238 | Proof. 239 | unfold Soundness. 240 | intros. 241 | apply (SLFixArray os 0); auto. 242 | Qed. 243 | 244 | Lemma soundness_array16_nil : 245 | Soundness (Array16 []) ["220"; "000"; "000"]. 246 | Proof. 247 | unfold Soundness. 248 | intros. 249 | apply (SLArray16 os 0 _ _ bs' "000" "000"); auto. 250 | Qed. 251 | 252 | 253 | Lemma soundness_array32_nil: 254 | Soundness (Array32 []) ["221"; "000"; "000";"000"; "000"]. 255 | Proof. 256 | unfold Soundness. 257 | intros. 258 | apply (SLArray32 os 0 _ _ bs' "000" "000" "000" "000"); auto. 259 | Qed. 260 | 261 | Lemma soundness_fixmap_nil: 262 | Soundness (FixMap []) ["128"]. 263 | Proof. 264 | unfold Soundness. 265 | intros. 266 | apply (SLFixMap os 0 _ _ _ _ [] _ bs'); auto. 267 | Qed. 268 | 269 | Lemma soundness_map16_nil: 270 | Soundness (Map16 []) ["222"; "000"; "000"]. 271 | Proof. 272 | unfold Soundness. 273 | intros. 274 | apply (SLMap16 os 0 [] _ bs' "000" "000"); auto. 275 | Qed. 276 | 277 | Lemma soundness_map32_nil: 278 | Soundness (Map32 []) ["223"; "000"; "000";"000"; "000"]. 279 | Proof. 280 | unfold Soundness. 281 | intros. 282 | apply (SLMap32 os 0 [] _ bs' "000" "000" "000" "000"); auto. 283 | Qed. 284 | 285 | Lemma soundness_fixarray_cons: forall x xs y ys b1 b2 b3 b4 b5 b6 b7 b8, 286 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 287 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length (x::xs)) -> 288 | Serialized x y -> 289 | Soundness x y -> 290 | Serialized (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 291 | Soundness (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 292 | Soundness (FixArray (x :: xs)) ((Ascii b5 b6 b7 b8 true false false true)::y ++ ys). 293 | Proof. 294 | unfold Soundness. 295 | intros. 296 | simpl. 297 | rewrite app_cons. 298 | inversion H6. 299 | apply (SLFixArray (x::(xs++os)) (length (x::xs))); auto. 300 | apply (H2 (xs++os) (ys++bs')) in H1; auto. 301 | apply (H4 os bs') in H3; auto. 302 | inversion H3. 303 | apply split_at_soundness in H21. 304 | rewrite H21 in *. 305 | assumption. 306 | 307 | apply split_at_length. 308 | Qed. 309 | 310 | Lemma soundness_array16_cons: forall x xs t1 t2 s1 s2 y ys, 311 | (t1, t2) = ascii16_of_nat (length xs) -> 312 | (s1, s2) = ascii16_of_nat (length (x :: xs)) -> 313 | Serialized x y -> 314 | Soundness x y -> 315 | Serialized (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 316 | Soundness (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 317 | Soundness (Array16 (x :: xs)) ("220" :: s1 :: s2 :: y ++ ys). 318 | Proof. 319 | unfold Soundness. 320 | intros. 321 | simpl. 322 | rewrite app_cons. 323 | inversion H6. 324 | apply (SLArray16 (x::(xs++os)) (length (x::xs))); auto. 325 | apply (H2 (xs++os) (ys++bs')) in H1; auto. 326 | apply (H4 os bs') in H3; auto. 327 | inversion H3. 328 | apply split_at_soundness in H19. 329 | rewrite H19 in *. 330 | assumption. 331 | 332 | apply split_at_length. 333 | Qed. 334 | 335 | Lemma soundness_array32_cons: forall x xs y ys s1 s2 s3 s4 t1 t2 t3 t4, 336 | ((t1,t2),(t3,t4)) = ascii32_of_nat (length xs) -> 337 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length (x::xs)) -> 338 | Serialized x y -> 339 | Soundness x y -> 340 | Serialized (Array32 xs) ("221"::t1::t2::t3::t4::ys) -> 341 | Soundness (Array32 xs) ("221"::t1::t2::t3::t4::ys) -> 342 | Soundness (Array32 (x::xs)) ("221"::s1::s2::s3::s4::y ++ ys). 343 | Proof. 344 | unfold Soundness. 345 | intros. 346 | simpl. 347 | rewrite app_cons. 348 | inversion H6. 349 | apply (SLArray32 (x::(xs++os)) (length (x::xs))); auto. 350 | apply (H2 (xs++os) (ys++bs')) in H1; auto. 351 | apply (H4 os bs') in H3; auto. 352 | inversion H3. 353 | apply split_at_soundness in H21. 354 | rewrite H21 in *. 355 | assumption. 356 | 357 | apply split_at_length. 358 | Qed. 359 | 360 | 361 | Lemma soundness_fixmap_cons: forall x1 x2 xs y1 y2 ys b1 b2 b3 b4 b5 b6 b7 b8, 362 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 363 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length ((x1,x2)::xs)) -> 364 | Serialized x1 y1 -> Soundness x1 y1 -> 365 | Serialized x2 y2 -> Soundness x2 y2 -> 366 | Serialized (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 367 | Soundness (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 368 | Soundness (FixMap ((x1, x2) :: xs)) (Ascii b5 b6 b7 b8 false false false true :: y1 ++ y2 ++ ys). 369 | Proof with auto. 370 | unfold Soundness. 371 | intros. 372 | simpl. 373 | rewrite app_cons. 374 | rewrite <- app_assoc. 375 | rewrite <- (pair_unpair _ ( (x1, x2) :: xs )). 376 | inversion H8. 377 | apply (SLFixMap (x1::x2::unpair xs++os) (length ((x1,x2)::xs))); auto. 378 | apply (H2 ( x2 :: unpair xs ++ os ) ( y2 ++ ys ++ bs' )) in H1; auto. 379 | apply (H4 ( unpair xs ++ os) ( ys ++ bs')) in H3; auto. 380 | apply (H6 os bs') in H5; auto. 381 | inversion H5. 382 | rewrite (unpair_pair _ n); auto. 383 | apply split_at_soundness in H25. 384 | rewrite <- H25... 385 | 386 | apply unpair_split_at. 387 | 388 | apply unpair_length. 389 | Qed. 390 | 391 | Lemma soundness_map16_cons: forall x1 x2 xs y1 y2 ys s1 s2 t1 t2, 392 | (t1, t2) = ascii16_of_nat (length xs) -> 393 | (s1, s2) = ascii16_of_nat (length ((x1, x2) :: xs)) -> 394 | Serialized x1 y1 -> 395 | Soundness x1 y1 -> 396 | Serialized x2 y2 -> 397 | Soundness x2 y2 -> 398 | Serialized (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 399 | Soundness (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 400 | Soundness (Map16 ((x1, x2) :: xs)) ("222" :: s1 :: s2 :: y1 ++ y2 ++ ys). 401 | Proof with auto. 402 | unfold Soundness. 403 | intros. 404 | simpl. 405 | rewrite app_cons. 406 | rewrite <- app_assoc. 407 | rewrite <- (pair_unpair _ ( (x1, x2) :: xs )). 408 | inversion H8. 409 | apply (SLMap16 (x1::x2::unpair xs++os) (length ((x1,x2)::xs))); auto. 410 | apply (H2 ( x2 :: unpair xs ++ os ) ( y2 ++ ys ++ bs' )) in H1; auto. 411 | apply (H4 ( unpair xs ++ os) ( ys ++ bs')) in H3; auto. 412 | apply (H6 os bs') in H5; auto. 413 | inversion H5. 414 | rewrite (unpair_pair _ n); auto. 415 | apply split_at_soundness in H23. 416 | rewrite <- H23... 417 | 418 | apply unpair_split_at. 419 | 420 | apply unpair_length. 421 | Qed. 422 | 423 | Lemma soundness_map32_cons : forall x1 x2 xs y1 y2 ys s1 s2 s3 s4 t1 t2 t3 t4, 424 | (t1, t2, (t3, t4)) = ascii32_of_nat (length xs) -> 425 | (s1, s2, (s3, s4)) = ascii32_of_nat (length ((x1, x2) :: xs)) -> 426 | Serialized x1 y1 -> 427 | Soundness x1 y1 -> 428 | Serialized x2 y2 -> 429 | Soundness x2 y2 -> 430 | Serialized (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 431 | Soundness (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 432 | Soundness (Map32 ((x1, x2) :: xs)) ("223" :: s1 :: s2 :: s3 :: s4 :: y1 ++ y2 ++ ys). 433 | Proof with auto. 434 | unfold Soundness. 435 | intros. 436 | simpl. 437 | rewrite app_cons. 438 | rewrite <- app_assoc. 439 | rewrite <- (pair_unpair _ ( (x1, x2) :: xs )). 440 | inversion H8. 441 | apply (SLMap32 (x1::x2::unpair xs++os) (length ((x1,x2)::xs))); auto. 442 | apply (H2 ( x2 :: unpair xs ++ os ) ( y2 ++ ys ++ bs' )) in H1; auto. 443 | apply (H4 ( unpair xs ++ os) ( ys ++ bs')) in H3; auto. 444 | apply (H6 os bs') in H5; auto. 445 | inversion H5. 446 | rewrite (unpair_pair _ n); auto. 447 | apply split_at_soundness in H25. 448 | rewrite <- H25... 449 | 450 | apply unpair_split_at. 451 | 452 | apply unpair_length. 453 | Qed. 454 | 455 | Lemma soundness_intro : forall obj xs, 456 | (Serialized obj xs -> Soundness obj xs) -> 457 | Soundness obj xs. 458 | Proof. 459 | unfold Soundness. 460 | intros. 461 | eapply H in H0; auto. 462 | apply H0. 463 | auto. 464 | Qed. 465 | 466 | Hint Resolve 467 | soundness_true soundness_false 468 | soundness_nil soundness_pfixnum soundness_nfixnum 469 | soundness_uint8 soundness_uint16 soundness_uint32 soundness_uint64 470 | soundness_int8 soundness_int16 soundness_int32 soundness_int64 471 | soundness_float soundness_double 472 | soundness_raw16 soundness_raw32 473 | soundness_fixarray_nil soundness_array16_nil soundness_array32_nil 474 | soundness_fixmap_nil soundness_map16_nil soundness_map32_nil 475 | : soundness. 476 | 477 | 478 | Theorem serialize_soundness : forall obj xs, 479 | Soundness obj xs. 480 | Proof. 481 | intros. 482 | apply soundness_intro. 483 | intro. 484 | pattern obj,xs. 485 | apply Serialized_ind; intros; auto with soundness. 486 | apply soundness_fixraw; auto. 487 | apply soundness_fixarray_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 488 | apply soundness_array16_cons with (t1:=t1) (t2:=t2); auto. 489 | apply soundness_array32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 490 | apply soundness_fixmap_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 491 | apply soundness_map16_cons with (t1:=t1) (t2:=t2); auto. 492 | apply soundness_map32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 493 | Qed. 494 | 495 | Lemma sl_soundness: forall o os bs bs', 496 | Serialized o bs -> 497 | Valid o -> 498 | SerializedList os bs' -> 499 | SerializedList (o :: os) (bs ++ bs'). 500 | Proof. 501 | intros. 502 | apply soundness_intro; auto. 503 | intro. 504 | pattern o, bs. 505 | apply Serialized_ind; intros; auto with soundness. 506 | apply soundness_fixraw; auto. 507 | apply soundness_fixarray_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 508 | apply soundness_array16_cons with (t1:=t1) (t2:=t2); auto. 509 | apply soundness_array32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 510 | apply soundness_fixmap_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 511 | apply soundness_map16_cons with (t1:=t1) (t2:=t2); auto. 512 | apply soundness_map32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 513 | Qed. 514 | -------------------------------------------------------------------------------- /proof/Soundness.v: -------------------------------------------------------------------------------- 1 | Require Import Ascii. 2 | Require Import ListUtil Object MultiByte SerializeSpec Prefix ProofUtil Pow. 3 | 4 | Definition Soundness obj1 x : Prop := forall obj2, 5 | Serialized obj1 x -> 6 | Serialized obj2 x -> 7 | Valid obj1 -> 8 | Valid obj2 -> 9 | obj1 = obj2. 10 | 11 | Ltac straightfoward := 12 | intros; 13 | unfold Soundness; 14 | intros obj2 Hs1 Hs2 V1 V2; 15 | inversion Hs2; 16 | reflexivity. 17 | 18 | Lemma soundness_nil: 19 | Soundness Nil ["192"]. 20 | Proof. 21 | straightfoward. 22 | Qed. 23 | 24 | Lemma soundness_true : 25 | Soundness (Bool true) ["195"]. 26 | Proof. 27 | straightfoward. 28 | Qed. 29 | 30 | Lemma soundness_false : 31 | Soundness (Bool false) ["194"]. 32 | Proof. 33 | straightfoward. 34 | Qed. 35 | 36 | Lemma soundness_pfixnum: forall x1 x2 x3 x4 x5 x6 x7, 37 | Soundness (PFixnum (Ascii x1 x2 x3 x4 x5 x6 x7 false)) 38 | [Ascii x1 x2 x3 x4 x5 x6 x7 false]. 39 | Proof. 40 | straightfoward. 41 | Qed. 42 | 43 | Lemma soundness_nfixnum: forall x1 x2 x3 x4 x5, 44 | Soundness (NFixnum (Ascii x1 x2 x3 x4 x5 true true true)) 45 | [Ascii x1 x2 x3 x4 x5 true true true]. 46 | Proof. 47 | straightfoward. 48 | Qed. 49 | 50 | Lemma soundness_uint8 : forall c, 51 | Soundness (Uint8 c) ("204"::list_of_ascii8 c). 52 | Proof. 53 | intros. 54 | unfold Soundness. 55 | intros obj2 Hs1 Hs2 V1 V2. 56 | inversion Hs2. 57 | rewrite_for obj2. 58 | auto. 59 | Qed. 60 | 61 | Lemma soundness_uint16 : forall c, 62 | Soundness (Uint16 c) ("205"::list_of_ascii16 c). 63 | Proof. 64 | intros. 65 | unfold Soundness. 66 | intros obj2 Hs1 Hs2 V1 V2. 67 | inversion Hs2. 68 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 69 | Qed. 70 | 71 | Lemma soundness_uint32 : forall c, 72 | Soundness (Uint32 c) ("206"::list_of_ascii32 c). 73 | Proof. 74 | intros. 75 | unfold Soundness. 76 | intros obj2 Hs1 Hs2 V1 V2. 77 | inversion Hs2. 78 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 79 | Qed. 80 | 81 | Lemma soundness_uint64 : forall c, 82 | Soundness (Uint64 c) ("207"::list_of_ascii64 c). 83 | Proof. 84 | intros. 85 | unfold Soundness. 86 | intros obj2 Hs1 Hs2 V1 V2. 87 | inversion Hs2. 88 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 89 | Qed. 90 | 91 | Lemma soundness_int8 : forall c, 92 | Soundness (Int8 c) ("208"::list_of_ascii8 c). 93 | Proof. 94 | intros. 95 | unfold Soundness. 96 | intros obj2 Hs1 Hs2 V1 V2. 97 | inversion Hs2. 98 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 99 | Qed. 100 | 101 | Lemma soundness_int16 : forall c, 102 | Soundness (Int16 c) ("209"::list_of_ascii16 c). 103 | Proof. 104 | intros. 105 | unfold Soundness. 106 | intros obj2 Hs1 Hs2 V1 V2. 107 | inversion Hs2. 108 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 109 | Qed. 110 | 111 | Lemma soundness_int32 : forall c, 112 | Soundness (Int32 c) ("210"::list_of_ascii32 c). 113 | Proof. 114 | intros. 115 | unfold Soundness. 116 | intros obj2 Hs1 Hs2 V1 V2. 117 | inversion Hs2. 118 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 119 | Qed. 120 | 121 | Lemma soundness_int64 : forall c, 122 | Soundness (Int64 c) ("211"::list_of_ascii64 c). 123 | Proof. 124 | intros. 125 | unfold Soundness. 126 | intros obj2 Hs1 Hs2 V1 V2. 127 | inversion Hs2. 128 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 129 | Qed. 130 | 131 | Lemma soundness_float : forall c, 132 | Soundness (Float c) ("202"::list_of_ascii32 c). 133 | Proof. 134 | intros. 135 | unfold Soundness. 136 | intros obj2 Hs1 Hs2 V1 V2. 137 | inversion Hs2. 138 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 139 | Qed. 140 | 141 | Lemma soundness_double : forall c, 142 | Soundness (Double c) ("203"::list_of_ascii64 c). 143 | Proof. 144 | intros. 145 | unfold Soundness. 146 | intros obj2 Hs1 Hs2 V1 V2. 147 | inversion Hs2. 148 | assert (c = c0); [| rewrite_for c ]; auto with ascii. 149 | Qed. 150 | 151 | Lemma soundness_fixraw : forall cs b1 b2 b3 b4 b5, 152 | Ascii b1 b2 b3 b4 b5 false false false = ascii8_of_nat (length cs) -> 153 | Soundness (FixRaw cs) ((Ascii b1 b2 b3 b4 b5 true false true)::cs). 154 | Proof. 155 | straightfoward. 156 | Qed. 157 | 158 | Lemma soundness_raw16: forall cs s1 s2, 159 | (s1,s2) = ascii16_of_nat (length cs) -> 160 | Soundness (Raw16 cs) ("218"::s1::s2::cs). 161 | Proof. 162 | straightfoward. 163 | Qed. 164 | 165 | Lemma soundness_raw32 : forall cs s1 s2 s3 s4, 166 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length cs) -> 167 | Soundness (Raw32 cs) ("219"::s1::s2::s3::s4::cs). 168 | Proof. 169 | straightfoward. 170 | Qed. 171 | 172 | Lemma soundness_fixarray_nil : 173 | Soundness (FixArray []) ["144"]. 174 | Proof. 175 | unfold Soundness. 176 | intros. 177 | inversion H0; auto. 178 | apply ascii8_not_O in H10; [ contradiction |]. 179 | split; [ simpl; omega |]. 180 | rewrite_for obj2. 181 | inversion H2. 182 | transitivity (pow 4); [ assumption |]. 183 | apply pow_lt. 184 | auto. 185 | Qed. 186 | 187 | Lemma soundness_array16_nil : 188 | Soundness (Array16 []) ["220"; "000"; "000"]. 189 | Proof. 190 | unfold Soundness. 191 | intros. 192 | inversion H0; auto. 193 | apply ascii16_not_O in H8; [ contradiction |]. 194 | split; [ simpl; omega |]. 195 | rewrite_for obj2. 196 | inversion H2. 197 | assumption. 198 | Qed. 199 | 200 | Lemma soundness_array32_nil: 201 | Soundness (Array32 []) ["221"; "000"; "000";"000"; "000"]. 202 | Proof. 203 | unfold Soundness. 204 | intros. 205 | inversion H0; auto. 206 | apply ascii32_not_O in H10; [ contradiction |]. 207 | split; [ simpl; omega |]. 208 | rewrite_for obj2. 209 | inversion H2. 210 | assumption. 211 | Qed. 212 | 213 | Lemma soundness_fixmap_nil: 214 | Soundness (FixMap []) ["128"]. 215 | Proof. 216 | unfold Soundness. 217 | intros. 218 | inversion H0; auto. 219 | apply ascii8_not_O in H10; [ contradiction |]. 220 | split; [ simpl; omega |]. 221 | rewrite_for obj2. 222 | inversion H2. 223 | transitivity (pow 4); [ assumption |]. 224 | apply pow_lt. 225 | auto. 226 | Qed. 227 | 228 | Lemma soundness_map16_nil: 229 | Soundness (Map16 []) ["222"; "000"; "000"]. 230 | Proof. 231 | unfold Soundness. 232 | intros. 233 | inversion H0; auto. 234 | apply ascii16_not_O in H7; [ contradiction |]. 235 | split; [ simpl; omega |]. 236 | rewrite_for obj2. 237 | inversion H2. 238 | assumption. 239 | Qed. 240 | 241 | Lemma soundness_map32_nil: 242 | Soundness (Map32 []) ["223"; "000"; "000";"000"; "000"]. 243 | Proof. 244 | unfold Soundness. 245 | intros. 246 | inversion H0; auto. 247 | apply ascii32_not_O in H10; [ contradiction |]. 248 | split; [ simpl; omega |]. 249 | rewrite_for obj2. 250 | inversion H2. 251 | assumption. 252 | Qed. 253 | 254 | Lemma soundness_fixarray_cons: forall x xs y ys b1 b2 b3 b4 b5 b6 b7 b8, 255 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 256 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length (x::xs)) -> 257 | Serialized x y -> 258 | Soundness x y -> 259 | Serialized (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 260 | Soundness (FixArray xs) ((Ascii b1 b2 b3 b4 true false false true)::ys) -> 261 | Soundness (FixArray (x :: xs)) ((Ascii b5 b6 b7 b8 true false false true)::y ++ ys). 262 | Proof. 263 | unfold Soundness. 264 | intros. 265 | inversion H6. 266 | rewrite_for b5. 267 | rewrite_for b6. 268 | rewrite_for b7. 269 | rewrite_for b8. 270 | apply ascii8_not_O in H0; [ contradiction |]. 271 | split; [ simpl; omega |]. 272 | inversion H7. 273 | transitivity (pow 4); [| apply pow_lt ]; auto. 274 | 275 | rewrite_for obj2. 276 | inversion H7. 277 | inversion H8. 278 | assert (y = y0). 279 | generalize prefix. 280 | unfold Prefix. 281 | intro Hprefix. 282 | apply (Hprefix x _ x0 _ ys ys0); auto. 283 | 284 | rewrite_for y0. 285 | apply H2 with (obj2:=x0) in H1; auto. 286 | apply app_same in H15. 287 | apply H4 with (obj2:=(FixArray xs0)) in H3; auto. 288 | inversion H3. 289 | rewrite H1. 290 | reflexivity. 291 | 292 | rewrite H16 in H0. 293 | apply ascii8_of_nat_eq in H0; [| transitivity (pow 4); [| apply pow_lt]; auto 294 | | transitivity (pow 4); [| apply pow_lt]; auto]. 295 | simpl H0. 296 | inversion H0. 297 | rewrite <- H29 in H. 298 | rewrite <- H14 in H. 299 | inversion H. 300 | rewrite_for b9. 301 | rewrite_for b10. 302 | rewrite_for ys. 303 | assumption. 304 | Qed. 305 | 306 | Lemma soundness_array16_cons: forall x xs t1 t2 s1 s2 y ys, 307 | (t1, t2) = ascii16_of_nat (length xs) -> 308 | (s1, s2) = ascii16_of_nat (length (x :: xs)) -> 309 | Serialized x y -> 310 | (Serialized x y -> Soundness x y) -> 311 | Serialized (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 312 | (Serialized (Array16 xs) ("220" :: t1 :: t2 :: ys) -> 313 | Soundness (Array16 xs) ("220" :: t1 :: t2 :: ys)) -> 314 | Soundness (Array16 (x :: xs)) ("220" :: s1 :: s2 :: y ++ ys). 315 | Proof. 316 | unfold Soundness. 317 | intros. 318 | inversion H6. 319 | rewrite_for s1. 320 | rewrite_for s2. 321 | apply ascii16_not_O in H0; [ contradiction |]. 322 | split; [ simpl; omega |]. 323 | inversion H7. 324 | assumption. 325 | 326 | rewrite_for obj2. 327 | inversion H7. 328 | inversion H8. 329 | assert (y = y0). 330 | generalize prefix. 331 | unfold Prefix. 332 | intro Hprefix. 333 | apply (Hprefix x _ x0 _ ys ys0); auto. 334 | 335 | rewrite_for y0. 336 | apply H2 with (obj2:=x0) in H1; auto. 337 | apply app_same in H11. 338 | apply H4 with (obj2:=(Array16 xs0)) in H3; auto. 339 | inversion H3. 340 | rewrite H1. 341 | reflexivity. 342 | 343 | rewrite H14 in H0. 344 | simpl in H0. 345 | apply ascii16_of_nat_eq in H0; auto. 346 | inversion H0. 347 | rewrite <- H27 in H. 348 | rewrite <- H12 in H. 349 | inversion H. 350 | rewrite_for t0. 351 | rewrite_for t3. 352 | rewrite_for ys. 353 | assumption. 354 | Qed. 355 | 356 | Lemma soundness_array32_cons: forall x xs y ys s1 s2 s3 s4 t1 t2 t3 t4, 357 | ((t1,t2),(t3,t4)) = ascii32_of_nat (length xs) -> 358 | ((s1,s2),(s3,s4)) = ascii32_of_nat (length (x::xs)) -> 359 | Serialized x y -> 360 | (Serialized x y -> Soundness x y) -> 361 | Serialized (Array32 xs) ("221"::t1::t2::t3::t4::ys) -> 362 | (Serialized (Array32 xs) ("221"::t1::t2::t3::t4::ys) -> Soundness (Array32 xs) ("221"::t1::t2::t3::t4::ys)) -> 363 | Soundness (Array32 (x::xs)) ("221"::s1::s2::s3::s4::y ++ ys). 364 | Proof. 365 | unfold Soundness. 366 | intros. 367 | inversion H6. 368 | rewrite_for s1. 369 | rewrite_for s2. 370 | rewrite_for s3. 371 | rewrite_for s4. 372 | apply ascii32_not_O in H0; [ contradiction |]. 373 | split; [ simpl; omega |]. 374 | inversion H7. 375 | assumption. 376 | 377 | rewrite_for obj2. 378 | inversion H7. 379 | inversion H8. 380 | assert (y = y0). 381 | generalize prefix. 382 | unfold Prefix. 383 | intro Hprefix. 384 | apply (Hprefix x _ x0 _ ys ys0); auto. 385 | 386 | rewrite_for y0. 387 | apply H2 with (obj2:=x0) in H1; auto. 388 | apply app_same in H15. 389 | apply H4 with (obj2:=(Array32 xs0)) in H3; auto. 390 | inversion H3. 391 | rewrite H1. 392 | reflexivity. 393 | 394 | rewrite H16 in H0. 395 | simpl in H0. 396 | apply ascii32_of_nat_eq in H0; auto. 397 | inversion H0. 398 | rewrite <- H29 in H. 399 | rewrite <- H14 in H. 400 | inversion H. 401 | rewrite_for t0. 402 | rewrite_for t5. 403 | rewrite_for t6. 404 | rewrite_for t7. 405 | rewrite_for ys. 406 | assumption. 407 | Qed. 408 | 409 | Lemma soundness_fixmap_cons: forall x1 x2 xs y1 y2 ys b1 b2 b3 b4 b5 b6 b7 b8, 410 | Ascii b1 b2 b3 b4 false false false false = ascii8_of_nat (length xs) -> 411 | Ascii b5 b6 b7 b8 false false false false = ascii8_of_nat (length ((x1,x2)::xs)) -> 412 | Serialized x1 y1 -> Soundness x1 y1 -> 413 | Serialized x2 y2 -> Soundness x2 y2 -> 414 | Serialized (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 415 | Soundness (FixMap xs) (Ascii b1 b2 b3 b4 false false false true :: ys) -> 416 | Soundness (FixMap ((x1, x2) :: xs)) (Ascii b5 b6 b7 b8 false false false true :: y1 ++ y2 ++ ys). 417 | Proof. 418 | unfold Soundness. 419 | intros. 420 | inversion H8. 421 | rewrite_for b5. 422 | rewrite_for b6. 423 | rewrite_for b7. 424 | rewrite_for b8. 425 | apply ascii8_not_O in H0; [ contradiction |]. 426 | split; [ simpl; omega |]. 427 | inversion H9. 428 | transitivity (pow 4); [| apply pow_lt]; auto. 429 | 430 | rewrite_for obj2. 431 | inversion H9. 432 | inversion H10. 433 | generalize prefix. 434 | unfold Prefix. 435 | intro Hprefix. 436 | assert (y1 = y0). 437 | apply (Hprefix x1 _ x0 _ (y2 ++ ys) (y3 ++ ys0)); auto. 438 | 439 | rewrite_for y0. 440 | apply app_same in H15. 441 | assert (y2 = y3). 442 | apply (Hprefix x2 _ x3 _ ys ys0); auto. 443 | 444 | rewrite_for y3. 445 | apply H2 with (obj2:=x0) in H1; auto. 446 | apply H4 with (obj2:=x3) in H3; auto. 447 | apply H6 with (obj2:=(FixMap xs0)) in H5; auto. 448 | inversion H5. 449 | rewrite H1, H3. 450 | reflexivity. 451 | 452 | rewrite H18 in H0. 453 | simpl in H0. 454 | apply ascii8_of_nat_eq in H0; [| transitivity (pow 4); [| apply pow_lt]; auto 455 | | transitivity (pow 4); [| apply pow_lt]; auto]. 456 | inversion H0. 457 | rewrite <- H36 in H. 458 | rewrite <- H17 in H. 459 | inversion H. 460 | rewrite_for b0. 461 | rewrite_for b9. 462 | rewrite_for b10. 463 | rewrite_for b11. 464 | apply app_same in H15. 465 | rewrite_for ys. 466 | assumption. 467 | Qed. 468 | 469 | Lemma soundness_map16_cons: forall x1 x2 xs y1 y2 ys s1 s2 t1 t2, 470 | (t1, t2) = ascii16_of_nat (length xs) -> 471 | (s1, s2) = ascii16_of_nat (length ((x1, x2) :: xs)) -> 472 | Serialized x1 y1 -> 473 | Soundness x1 y1 -> 474 | Serialized x2 y2 -> 475 | Soundness x2 y2 -> 476 | Serialized (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 477 | Soundness (Map16 xs) ("222" :: t1 :: t2 :: ys) -> 478 | Soundness (Map16 ((x1, x2) :: xs)) ("222" :: s1 :: s2 :: y1 ++ y2 ++ ys). 479 | Proof. 480 | unfold Soundness. 481 | intros. 482 | inversion H8. 483 | rewrite_for s1. 484 | rewrite_for s2. 485 | apply ascii16_not_O in H0; [ contradiction |]. 486 | split; [ simpl; omega |]. 487 | inversion H9. 488 | assumption. 489 | 490 | rewrite_for obj2. 491 | inversion H9. 492 | inversion H10. 493 | generalize prefix. 494 | unfold Prefix. 495 | intro Hprefix. 496 | assert (y1 = y0). 497 | apply (Hprefix x1 _ x0 _ (y2 ++ ys) (y3 ++ ys0)); auto. 498 | 499 | rewrite_for y0. 500 | apply app_same in H13. 501 | assert (y2 = y3). 502 | apply (Hprefix x2 _ x3 _ ys ys0); auto. 503 | 504 | rewrite_for y3. 505 | 506 | apply H2 with (obj2:=x0) in H1; auto. 507 | apply H4 with (obj2:=x3) in H3; auto. 508 | apply H6 with (obj2:=(Map16 xs0)) in H5; auto. 509 | inversion H5. 510 | rewrite H1, H3. 511 | reflexivity. 512 | 513 | rewrite H15 in H0. 514 | simpl in H0. 515 | apply ascii16_of_nat_eq in H0; auto. 516 | inversion H0. 517 | rewrite <- H34 in H. 518 | rewrite <- H14 in H. 519 | inversion H. 520 | rewrite_for t0. 521 | rewrite_for t3. 522 | apply app_same in H13. 523 | rewrite_for ys. 524 | assumption. 525 | Qed. 526 | 527 | Lemma soundness_map32_cons : forall x1 x2 xs y1 y2 ys s1 s2 s3 s4 t1 t2 t3 t4, 528 | (t1, t2, (t3, t4)) = ascii32_of_nat (length xs) -> 529 | (s1, s2, (s3, s4)) = ascii32_of_nat (length ((x1, x2) :: xs)) -> 530 | Serialized x1 y1 -> 531 | Soundness x1 y1 -> 532 | Serialized x2 y2 -> 533 | Soundness x2 y2 -> 534 | Serialized (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 535 | Soundness (Map32 xs) ("223" :: t1 :: t2 :: t3 :: t4 :: ys) -> 536 | Soundness (Map32 ((x1, x2) :: xs)) ("223" :: s1 :: s2 :: s3 :: s4 :: y1 ++ y2 ++ ys). 537 | Proof. 538 | unfold Soundness. 539 | intros. 540 | inversion H8. 541 | rewrite_for s1. 542 | rewrite_for s2. 543 | rewrite_for s3. 544 | rewrite_for s4. 545 | apply ascii32_not_O in H0; [ contradiction |]. 546 | split; [ simpl; omega |]. 547 | inversion H9. 548 | assumption. 549 | 550 | rewrite_for obj2. 551 | inversion H9. 552 | inversion H10. 553 | generalize prefix. 554 | unfold Prefix. 555 | intro Hprefix. 556 | assert (y1 = y0). 557 | apply (Hprefix x1 _ x0 _ (y2 ++ ys) (y3 ++ ys0)); auto. 558 | 559 | rewrite_for y0. 560 | apply app_same in H15. 561 | assert (y2 = y3). 562 | apply (Hprefix x2 _ x3 _ ys ys0); auto. 563 | 564 | rewrite_for y3. 565 | apply H2 with (obj2:=x0) in H1; auto. 566 | apply H4 with (obj2:=x3) in H3; auto. 567 | apply H6 with (obj2:=(Map32 xs0)) in H5; auto. 568 | inversion H5. 569 | rewrite H1, H3. 570 | reflexivity. 571 | 572 | rewrite H18 in H0. 573 | simpl in H0. 574 | apply ascii32_of_nat_eq in H0; auto. 575 | inversion H0. 576 | rewrite <- H36 in H. 577 | rewrite <- H17 in H. 578 | inversion H. 579 | rewrite_for t0. 580 | rewrite_for t5. 581 | rewrite_for t6. 582 | rewrite_for t7. 583 | apply app_same in H15. 584 | rewrite_for ys. 585 | assumption. 586 | Qed. 587 | 588 | Hint Resolve 589 | soundness_true soundness_false 590 | soundness_nil soundness_pfixnum soundness_nfixnum 591 | soundness_uint8 soundness_uint16 soundness_uint32 soundness_uint64 592 | soundness_int8 soundness_int16 soundness_int32 soundness_int64 593 | soundness_float soundness_double 594 | soundness_raw16 soundness_raw32 595 | soundness_fixarray_nil soundness_array16_nil soundness_array32_nil 596 | soundness_fixmap_nil soundness_map16_nil soundness_map32_nil 597 | : soundness. 598 | 599 | Lemma soundness_intro: forall obj x, 600 | (Serialized obj x -> Soundness obj x)-> 601 | Soundness obj x. 602 | Proof. 603 | unfold Soundness. 604 | intros. 605 | apply H in H1; auto. 606 | Qed. 607 | 608 | Theorem soundness : forall obj1 x, 609 | Soundness obj1 x. 610 | Proof. 611 | intros. 612 | apply soundness_intro. 613 | intro. 614 | pattern obj1,x. 615 | apply Serialized_ind; intros; auto with soundness. 616 | apply soundness_fixraw; auto. 617 | apply soundness_fixarray_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 618 | apply soundness_array16_cons with (t1:=t1) (t2:=t2); auto. 619 | apply soundness_array32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 620 | apply soundness_fixmap_cons with (b1:=b1) (b2:=b2) (b3:=b3) (b4:=b4); auto. 621 | apply soundness_map16_cons with (t1:=t1) (t2:=t2); auto. 622 | apply soundness_map32_cons with (t1:=t1) (t2:=t2) (t3:=t3) (t4:=t4); auto. 623 | Qed. 624 | -------------------------------------------------------------------------------- /proof/Util.v: -------------------------------------------------------------------------------- 1 | Require Ascii List. 2 | Require Import ExtractUtil. 3 | 4 | Definition mlchar_of_ascii a := 5 | mlchar_of_mlint (mlint_of_nat (Ascii.nat_of_ascii a)). 6 | Definition mlstring_of_string s := 7 | mlstring_of_list mlchar_of_ascii (list_of_string s). 8 | Definition ascii_of_mlchar c := 9 | Ascii.ascii_of_nat (nat_of_mlint (mlint_of_mlchar c)). 10 | Definition string_of_mlstring s := 11 | string_of_list (list_of_mlstring ascii_of_mlchar s). 12 | 13 | Definition print s := print_mlstring (mlstring_of_string s). 14 | Definition println s := println_mlstring (mlstring_of_string s). 15 | Definition prerr s := prerr_mlstring (mlstring_of_string s). 16 | Definition prerrln s := prerrln_mlstring (mlstring_of_string s). 17 | 18 | CoFixpoint lmap {A B:Type} (f: A -> B) (xs : llist A) : llist B := 19 | match xs with 20 | | LNil => LNil 21 | | LCons x xs => LCons (f x) (lmap f xs) 22 | end. 23 | 24 | Fixpoint ltake {A:Type} n (xs: llist A) := 25 | match (n, xs) with 26 | | (O, _) => List.nil 27 | | (_, LNil) => List.nil 28 | | (S n', LCons x xs) => List.cons x (ltake n' xs) 29 | end. 30 | 31 | Definition get_contents := lmap ascii_of_mlchar get_contents_mlchars. 32 | 33 | Definition id {A:Type} (x:A) := x. 34 | 35 | Notation "f @@ x" := (f x) (right associativity, at level 75, only parsing). 36 | -------------------------------------------------------------------------------- /test/conv/convTest.ml: -------------------------------------------------------------------------------- 1 | open Msgpack 2 | open Msgpack_conv 3 | open OUnit 4 | 5 | type t1 = { 6 | int : int; 7 | str : string; 8 | b : bool; 9 | f : float; 10 | u : unit; 11 | c : char; 12 | } [@@deriving conv{msgpack}] 13 | 14 | type t2 = 15 | int list [@@deriving conv{msgpack}] 16 | 17 | type t3 = 18 | int array [@@deriving conv{msgpack}] 19 | 20 | type t4 = 21 | string option [@@deriving conv{msgpack}] 22 | 23 | type t5 = 24 | int * string [@@deriving conv{msgpack}] 25 | 26 | type t6 = 27 | Foo of int | Bar [@@deriving conv{msgpack}] 28 | 29 | let check pack unpack x y = 30 | assert_equal x (pack y); 31 | assert_equal y (unpack x) 32 | 33 | let tests = [ 34 | "record" >:: begin fun () -> 35 | check 36 | msgpack_of_t1 t1_of_msgpack_exn 37 | (`FixMap [`FixRaw ['i'; 'n'; 't'], `PFixnum 42; 38 | `FixRaw ['s'; 't'; 'r'], `FixRaw ['b'; 'a'; 'z']; 39 | `FixRaw ['b'], `Bool true; 40 | `FixRaw ['f'], `Float 42.; 41 | `FixRaw ['u'], `Nil; 42 | `FixRaw ['c'], `FixRaw ['_']; 43 | ]) 44 | { int = 42; str = "baz"; b = true; f = 42.; u = (); c = '_' } 45 | end; 46 | "list" >:: begin fun () -> 47 | check 48 | msgpack_of_t2 t2_of_msgpack_exn 49 | (`FixArray [`PFixnum 1; `PFixnum 2; `PFixnum 3]) 50 | [ 1; 2; 3 ] 51 | end; 52 | "array" >:: begin fun () -> 53 | check 54 | msgpack_of_t3 t3_of_msgpack_exn 55 | (`FixArray [`PFixnum 1; `PFixnum 2; `PFixnum 3]) 56 | [| 1; 2; 3 |] 57 | end; 58 | "option" >:: begin fun () -> 59 | check 60 | msgpack_of_t4 t4_of_msgpack_exn 61 | `Nil None; 62 | check 63 | msgpack_of_t4 t4_of_msgpack_exn 64 | (`FixRaw ['f'; 'o'; 'o']) (Some "foo") 65 | end; 66 | "tuple" >:: begin fun () -> 67 | check 68 | msgpack_of_t5 t5_of_msgpack_exn 69 | (`FixArray [`PFixnum 0; `FixRaw ['x']]) (0, "x") 70 | end; 71 | "varint" >:: begin fun () -> 72 | check 73 | msgpack_of_t6 t6_of_msgpack_exn 74 | (`FixMap [`FixRaw ['F'; 'o'; 'o' ], `FixArray [`PFixnum 42]]) (Foo 42); 75 | check 76 | msgpack_of_t6 t6_of_msgpack_exn 77 | (`FixRaw ['B'; 'a'; 'r' ]) Bar 78 | end 79 | ] 80 | -------------------------------------------------------------------------------- /test/conv/main.ml: -------------------------------------------------------------------------------- 1 | 2 | let _ = 3 | OUnit.(run_test_tt_main ("conv" >::: [ 4 | "conv.ml" >::: ConvTest.tests; 5 | ])) 6 | -------------------------------------------------------------------------------- /test/core/main.ml: -------------------------------------------------------------------------------- 1 | 2 | let _ = 3 | OUnit.(run_test_tt_main ("core" >::: [ 4 | "pack.ml" >::: PackTest.tests; 5 | "serialize.ml" >::: SerializeTest.tests; 6 | ])) 7 | -------------------------------------------------------------------------------- /test/core/packTest.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Printf 3 | open Msgpack 4 | open MsgpackCore 5 | open Pack 6 | 7 | let (+>) f g = g f 8 | let ($) f g x = f (g x) 9 | 10 | let concat_map f xs = 11 | List.fold_right ((@) $ f) xs [] 12 | 13 | let c0 = 14 | Ascii (false,false,false,false,false,false,false,false) 15 | let c1 = 16 | Ascii (true, false,false,false,false,false,false,false) 17 | let c255 = 18 | Ascii (true,true,true,true,true,true,true,true) 19 | 20 | let valid = [ 21 | "nil",[ 22 | Nil, `Nil 23 | ], []; 24 | "bool",[ 25 | Bool true , `Bool true; 26 | Bool false, `Bool false 27 | ], []; 28 | "pfixnum",[ 29 | PFixnum c0,`PFixnum 0; 30 | PFixnum c1,`PFixnum 1; 31 | ], [ 32 | `PFixnum 128; 33 | `PFixnum (~-1); 34 | ]; 35 | "nfixnum",[ 36 | NFixnum c255, `NFixnum ~-1; 37 | NFixnum (Ascii (false,false,false,false,false,true,true,true)), `NFixnum ~-32 38 | ],[ 39 | `NFixnum 0; 40 | `NFixnum (~-33) 41 | ]; 42 | "uint8", [ 43 | Uint8 c0, `Uint8 0; 44 | Uint8 c1, `Uint8 1; 45 | Uint8 c255, `Uint8 255 46 | ],[ 47 | `Uint8 ~-1; 48 | `Uint8 256 49 | ]; 50 | "uint16", [ 51 | Uint16 (c0,c0), `Uint16 0; 52 | Uint16 (c0,c1), `Uint16 1; 53 | Uint16 (c1,c0), `Uint16 256; 54 | Uint16 (c255,c255), `Uint16 65535; 55 | ],[ 56 | `Uint16 ~-1; 57 | `Uint16 65536 58 | ]; 59 | "uint32", [ 60 | Uint32 ((c0,c0), (c0,c0)), `Uint32 0L; 61 | Uint32 ((c255,c255), (c255,c255)), `Uint32 0xFFFF_FFFFL 62 | ],[ 63 | `Uint32 (-1L); 64 | `Uint32 0x1FFFF_FFFFL 65 | ]; 66 | "uint64", [ 67 | Uint64 (((c0,c0), (c0,c0)),((c0,c0), (c0,c0))), `Uint64 Big_int.zero_big_int; 68 | Uint64 (((c0,c0), (c0,c0)),((c0,c0), (c0,c1))), `Uint64 Big_int.unit_big_int; 69 | Uint64 (((c255,c255), (c255,c255)),((c255,c255), (c255,c255))), `Uint64 (Big_int.big_int_of_string "18446744073709551615") 70 | ],[ 71 | `Uint64 (Big_int.big_int_of_string "-1"); 72 | `Uint64 (Big_int.big_int_of_string "18446744073709551617") 73 | ]; 74 | "int8", [ 75 | Int8 c0, `Int8 0; 76 | Int8 c1, `Int8 1; 77 | Int8 c255, `Int8 (~-1) 78 | ],[ 79 | `Int8 129 80 | ]; 81 | "int16", [ 82 | Int16 (c0,c0), `Int16 0; 83 | Int16 (c0,c1), `Int16 1; 84 | Int16 (c1,c0), `Int16 256; 85 | Int16 (c255,c255), `Int16 ~-1; 86 | ],[ 87 | `Int16 65536 88 | ]; 89 | "int32", [ 90 | Int32 ((c0,c0), (c0,c0)), `Int32 0l; 91 | Int32 ((c255,c255), (c255,c255)), `Int32 (-1l) 92 | ],[]; 93 | "int64", [ 94 | Int64 (((c0,c0), (c0,c0)),((c0,c0), (c0,c0))), `Int64 0L; 95 | Int64 (((c0,c0), (c0,c0)),((c0,c0), (c0,c1))), `Int64 1L; 96 | Int64 (((c255,c255), (c255,c255)),((c255,c255), (c255,c255))), `Int64 (-1L) 97 | ],[]; 98 | "float", [ 99 | Float ((c0,c0),(c0,c0)), `Float 0.0; 100 | (* 0.5 = 3f_00_00_00 *) 101 | Float ((Ascii (true,true,true,true,true,true,false,false),c0),(c0,c0)), `Float 0.5; 102 | ], []; 103 | "double", [ 104 | Double (((c0,c0),(c0,c0)),((c0,c0),(c0,c0))), `Double 0.0; 105 | (* 0.5 = 3f_e0_00_00_00_00_00_00 *) 106 | Double (((Ascii (true,true,true,true,true,true,false,false), 107 | Ascii (false,false,false,false,false,true,true,true)), 108 | (c0,c0)), 109 | ((c0,c0),(c0,c0))), `Double 0.5 110 | ],[]; 111 | "fixraw", [ 112 | FixRaw [], `FixRaw []; 113 | FixRaw [ c0 ], `FixRaw [ '\000']; 114 | FixRaw [ c0; c1 ], `FixRaw [ '\000'; '\001']; 115 | ],[]; 116 | "raw16", [ 117 | Raw16 [], `Raw16 []; 118 | Raw16 [ c0 ], `Raw16 [ '\000']; 119 | Raw16 [ c0; c1 ], `Raw16 [ '\000'; '\001']; 120 | ], []; 121 | "raw32", [ 122 | Raw32 [], `Raw32 []; 123 | Raw32 [ c0 ], `Raw32 [ '\000']; 124 | Raw32 [ c0; c1 ], `Raw32 [ '\000'; '\001']; 125 | ], []; 126 | "fixarray", [ 127 | FixArray [], `FixArray []; 128 | FixArray [ PFixnum c0 ], `FixArray [`PFixnum 0 ]; 129 | FixArray [ FixArray [ PFixnum c0 ] ], `FixArray [`FixArray [ `PFixnum 0] ]; 130 | ], []; 131 | "array16", [ 132 | Array16 [], `Array16 []; 133 | Array16 [ PFixnum c0 ], `Array16 [`PFixnum 0 ]; 134 | Array16 [ Array16 [ PFixnum c0 ] ], `Array16 [`Array16 [ `PFixnum 0] ]; 135 | ], []; 136 | "array32", [ 137 | Array32 [], `Array32 []; 138 | Array32 [ PFixnum c0 ], `Array32 [`PFixnum 0 ]; 139 | Array32 [ Array32 [ PFixnum c0 ] ], `Array32 [`Array32 [ `PFixnum 0] ]; 140 | ], []; 141 | "fixmap", [ 142 | FixMap [], `FixMap []; 143 | FixMap [ PFixnum c0, PFixnum c1 ], `FixMap [`PFixnum 0, `PFixnum 1 ]; 144 | ], []; 145 | "map16", [ 146 | Map16 [], `Map16 []; 147 | Map16 [ PFixnum c0, PFixnum c1 ], `Map16 [`PFixnum 0, `PFixnum 1 ]; 148 | ], []; 149 | "map32", [ 150 | Map32 [], `Map32 []; 151 | Map32 [ PFixnum c0, PFixnum c1 ], `Map32 [`PFixnum 0, `PFixnum 1 ]; 152 | ], []; 153 | ] 154 | 155 | 156 | let tests = [ 157 | "変換のテスト" >::: 158 | valid +> concat_map begin fun (name, ok, ng) -> 159 | let xs = 160 | ok +> List.map begin fun (expect, actual) -> 161 | (sprintf "%sが変換できる" name) >:: (fun _ -> assert_equal expect (pack actual)); 162 | end in 163 | let ys = 164 | ng +> List.map begin fun actual -> 165 | (sprintf "%sのエラーチェック" name) >:: (fun _ -> assert_raises (Not_conversion name) (fun () -> pack actual)) 166 | end in 167 | xs @ ys 168 | end; 169 | "復元のテスト" >::: 170 | valid +> concat_map begin fun (name, ok, _) -> 171 | ok +> List.map begin fun (actual, expect) -> 172 | (sprintf "%sが復元できる" name) >:: begin fun _ -> 173 | match expect, unpack actual with 174 | `Uint64 n1, `Uint64 n2 -> 175 | assert_equal ~cmp:Big_int.eq_big_int n1 n2 176 | | x, y -> 177 | assert_equal x y 178 | end 179 | end 180 | end; 181 | "long_string" >:: begin fun _ -> 182 | let rec make_list acc = function 183 | | 0 -> acc 184 | | n -> make_list ('A' :: acc) (n-1) 185 | in 186 | (* This will stack-overflow on x86-64 Linux with 8MB stack *) 187 | let orig = `Raw32 (make_list [] 10_000_000) in 188 | let packed = pack orig in 189 | assert_equal orig (unpack packed) 190 | end; 191 | ] 192 | -------------------------------------------------------------------------------- /test/core/serializeTest.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Msgpack.Serialize 3 | 4 | let tests = [ 5 | "Rubyのライブラリとの互換テスト(deserialize)" >:: begin fun _ -> 6 | (* [1,2,3].to_msgpack *) 7 | assert_equal (`FixArray [`PFixnum 1; `PFixnum 2; `PFixnum 3]) 8 | (deserialize_string "\147\001\002\003") 9 | end; 10 | "Rubyのライブラリとの互換テスト(serialize)" >:: begin fun _ -> 11 | assert_equal "\147\001\002\003" 12 | (serialize_string (`FixArray [`PFixnum 1; `PFixnum 2; `PFixnum 3])) 13 | end 14 | ] 15 | -------------------------------------------------------------------------------- /test/opam/package.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | git clean -fdx 4 | cd $PWD/$(git rev-parse --show-cdup) 5 | opam pin add msgpack . -y 6 | 7 | cd examples 8 | ./build.sh 9 | ./a.out && echo "ok" 10 | --------------------------------------------------------------------------------