├── .github
└── workflows
│ └── ci.yml
├── .gitignore
├── .ocamlformat
├── LICENSE
├── README.md
├── bin
├── dune
├── main.ml
└── stdlib.fc
├── dune-project
├── examples
└── wallet_v3.tact
├── js
├── dune
└── tact_js.ml
├── lib
├── attributes.ml
├── builtin.ml
├── codegen_func.ml
├── compiler.ml
├── config.ml
├── discriminator.ml
├── dune
├── errors.ml
├── func.ml
├── interpreter.ml
├── lang.ml
├── lang_types.ml
├── located.ml
├── parser.ml
├── partial_evaluator.ml
├── show.ml
├── std
│ └── std.tact
├── syntax.ml
├── type_check.ml
└── zint.ml
├── tact.opam
├── test
├── builtin.ml
├── builtin_basics.ml
├── codegen_func.ml
├── dune
├── errors.ml
├── immediacy_check.ml
├── lang.ml
├── lang_types.ml
├── shared.ml
├── std.ml
└── syntax.ml
├── tonvm.opam
└── tonvm
├── bitstr.ml
├── cp.ml
├── dune
├── instr.ml
├── instr_null.ml
├── instr_null_test.ml
├── instr_stack.ml
├── instr_stack_test.ml
├── tests.ml
├── tonvm.ml
├── vm.ml
└── zint.ml
/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
1 | name: CI
2 |
3 | on:
4 | pull_request:
5 | push:
6 | schedule:
7 | # Prime the caches every Monday
8 | - cron: 0 1 * * MON
9 |
10 | jobs:
11 | lint-fmt:
12 | runs-on: ubuntu-latest
13 | steps:
14 | - name: Checkout code
15 | uses: actions/checkout@v3
16 |
17 | - name: Use OCaml 4.14.x
18 | uses: ocaml/setup-ocaml@v2
19 | with:
20 | ocaml-compiler: 4.14.x
21 | dune-cache: true
22 |
23 | - name: Lint fmt
24 | uses: ocaml/setup-ocaml/lint-fmt@v2
25 | build:
26 | strategy:
27 | fail-fast: false
28 | matrix:
29 | os:
30 | - macos-latest
31 | - ubuntu-latest
32 | ocaml-compiler:
33 | - 4.14.x
34 |
35 | runs-on: ${{ matrix.os }}
36 |
37 | steps:
38 | - name: Checkout code
39 | uses: actions/checkout@v3
40 |
41 | - name: Use OCaml ${{ matrix.ocaml-compiler }}
42 | uses: ocaml/setup-ocaml@v2
43 | with:
44 | ocaml-compiler: ${{ matrix.ocaml-compiler }}
45 |
46 | - run: opam install . --deps-only --with-test
47 |
48 | - run: opam exec -- dune build
49 |
50 | - run: opam exec -- dune test
51 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | _build
2 | _opam
3 | *.swp
4 | .vscode
5 | .conflicts
6 | .DS_Store
7 | *.fc
8 | !bin/stdlib.fc
9 | *.fif
10 | *.cell
11 |
--------------------------------------------------------------------------------
/.ocamlformat:
--------------------------------------------------------------------------------
1 | profile = ocamlformat
2 | break-separators = after
3 | field-space = loose
4 | version = 0.23.0
5 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Apache License
2 | Version 2.0, January 2004
3 | http://www.apache.org/licenses/
4 |
5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
6 |
7 | 1. Definitions.
8 |
9 | "License" shall mean the terms and conditions for use, reproduction,
10 | and distribution as defined by Sections 1 through 9 of this document.
11 |
12 | "Licensor" shall mean the copyright owner or entity authorized by
13 | the copyright owner that is granting the License.
14 |
15 | "Legal Entity" shall mean the union of the acting entity and all
16 | other entities that control, are controlled by, or are under common
17 | control with that entity. For the purposes of this definition,
18 | "control" means (i) the power, direct or indirect, to cause the
19 | direction or management of such entity, whether by contract or
20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the
21 | outstanding shares, or (iii) beneficial ownership of such entity.
22 |
23 | "You" (or "Your") shall mean an individual or Legal Entity
24 | exercising permissions granted by this License.
25 |
26 | "Source" form shall mean the preferred form for making modifications,
27 | including but not limited to software source code, documentation
28 | source, and configuration files.
29 |
30 | "Object" form shall mean any form resulting from mechanical
31 | transformation or translation of a Source form, including but
32 | not limited to compiled object code, generated documentation,
33 | and conversions to other media types.
34 |
35 | "Work" shall mean the work of authorship, whether in Source or
36 | Object form, made available under the License, as indicated by a
37 | copyright notice that is included in or attached to the work
38 | (an example is provided in the Appendix below).
39 |
40 | "Derivative Works" shall mean any work, whether in Source or Object
41 | form, that is based on (or derived from) the Work and for which the
42 | editorial revisions, annotations, elaborations, or other modifications
43 | represent, as a whole, an original work of authorship. For the purposes
44 | of this License, Derivative Works shall not include works that remain
45 | separable from, or merely link (or bind by name) to the interfaces of,
46 | the Work and Derivative Works thereof.
47 |
48 | "Contribution" shall mean any work of authorship, including
49 | the original version of the Work and any modifications or additions
50 | to that Work or Derivative Works thereof, that is intentionally
51 | submitted to Licensor for inclusion in the Work by the copyright owner
52 | or by an individual or Legal Entity authorized to submit on behalf of
53 | the copyright owner. For the purposes of this definition, "submitted"
54 | means any form of electronic, verbal, or written communication sent
55 | to the Licensor or its representatives, including but not limited to
56 | communication on electronic mailing lists, source code control systems,
57 | and issue tracking systems that are managed by, or on behalf of, the
58 | Licensor for the purpose of discussing and improving the Work, but
59 | excluding communication that is conspicuously marked or otherwise
60 | designated in writing by the copyright owner as "Not a Contribution."
61 |
62 | "Contributor" shall mean Licensor and any individual or Legal Entity
63 | on behalf of whom a Contribution has been received by Licensor and
64 | subsequently incorporated within the Work.
65 |
66 | 2. Grant of Copyright License. Subject to the terms and conditions of
67 | this License, each Contributor hereby grants to You a perpetual,
68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable
69 | copyright license to reproduce, prepare Derivative Works of,
70 | publicly display, publicly perform, sublicense, and distribute the
71 | Work and such Derivative Works in Source or Object form.
72 |
73 | 3. Grant of Patent License. Subject to the terms and conditions of
74 | this License, each Contributor hereby grants to You a perpetual,
75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable
76 | (except as stated in this section) patent license to make, have made,
77 | use, offer to sell, sell, import, and otherwise transfer the Work,
78 | where such license applies only to those patent claims licensable
79 | by such Contributor that are necessarily infringed by their
80 | Contribution(s) alone or by combination of their Contribution(s)
81 | with the Work to which such Contribution(s) was submitted. If You
82 | institute patent litigation against any entity (including a
83 | cross-claim or counterclaim in a lawsuit) alleging that the Work
84 | or a Contribution incorporated within the Work constitutes direct
85 | or contributory patent infringement, then any patent licenses
86 | granted to You under this License for that Work shall terminate
87 | as of the date such litigation is filed.
88 |
89 | 4. Redistribution. You may reproduce and distribute copies of the
90 | Work or Derivative Works thereof in any medium, with or without
91 | modifications, and in Source or Object form, provided that You
92 | meet the following conditions:
93 |
94 | (a) You must give any other recipients of the Work or
95 | Derivative Works a copy of this License; and
96 |
97 | (b) You must cause any modified files to carry prominent notices
98 | stating that You changed the files; and
99 |
100 | (c) You must retain, in the Source form of any Derivative Works
101 | that You distribute, all copyright, patent, trademark, and
102 | attribution notices from the Source form of the Work,
103 | excluding those notices that do not pertain to any part of
104 | the Derivative Works; and
105 |
106 | (d) If the Work includes a "NOTICE" text file as part of its
107 | distribution, then any Derivative Works that You distribute must
108 | include a readable copy of the attribution notices contained
109 | within such NOTICE file, excluding those notices that do not
110 | pertain to any part of the Derivative Works, in at least one
111 | of the following places: within a NOTICE text file distributed
112 | as part of the Derivative Works; within the Source form or
113 | documentation, if provided along with the Derivative Works; or,
114 | within a display generated by the Derivative Works, if and
115 | wherever such third-party notices normally appear. The contents
116 | of the NOTICE file are for informational purposes only and
117 | do not modify the License. You may add Your own attribution
118 | notices within Derivative Works that You distribute, alongside
119 | or as an addendum to the NOTICE text from the Work, provided
120 | that such additional attribution notices cannot be construed
121 | as modifying the License.
122 |
123 | You may add Your own copyright statement to Your modifications and
124 | may provide additional or different license terms and conditions
125 | for use, reproduction, or distribution of Your modifications, or
126 | for any such Derivative Works as a whole, provided Your use,
127 | reproduction, and distribution of the Work otherwise complies with
128 | the conditions stated in this License.
129 |
130 | 5. Submission of Contributions. Unless You explicitly state otherwise,
131 | any Contribution intentionally submitted for inclusion in the Work
132 | by You to the Licensor shall be under the terms and conditions of
133 | this License, without any additional terms or conditions.
134 | Notwithstanding the above, nothing herein shall supersede or modify
135 | the terms of any separate license agreement you may have executed
136 | with Licensor regarding such Contributions.
137 |
138 | 6. Trademarks. This License does not grant permission to use the trade
139 | names, trademarks, service marks, or product names of the Licensor,
140 | except as required for reasonable and customary use in describing the
141 | origin of the Work and reproducing the content of the NOTICE file.
142 |
143 | 7. Disclaimer of Warranty. Unless required by applicable law or
144 | agreed to in writing, Licensor provides the Work (and each
145 | Contributor provides its Contributions) on an "AS IS" BASIS,
146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
147 | implied, including, without limitation, any warranties or conditions
148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
149 | PARTICULAR PURPOSE. You are solely responsible for determining the
150 | appropriateness of using or redistributing the Work and assume any
151 | risks associated with Your exercise of permissions under this License.
152 |
153 | 8. Limitation of Liability. In no event and under no legal theory,
154 | whether in tort (including negligence), contract, or otherwise,
155 | unless required by applicable law (such as deliberate and grossly
156 | negligent acts) or agreed to in writing, shall any Contributor be
157 | liable to You for damages, including any direct, indirect, special,
158 | incidental, or consequential damages of any character arising as a
159 | result of this License or out of the use or inability to use the
160 | Work (including but not limited to damages for loss of goodwill,
161 | work stoppage, computer failure or malfunction, or any and all
162 | other commercial damages or losses), even if such Contributor
163 | has been advised of the possibility of such damages.
164 |
165 | 9. Accepting Warranty or Additional Liability. While redistributing
166 | the Work or Derivative Works thereof, You may choose to offer,
167 | and charge a fee for, acceptance of support, warranty, indemnity,
168 | or other liability obligations and/or rights consistent with this
169 | License. However, in accepting such obligations, You may act only
170 | on Your own behalf and on Your sole responsibility, not on behalf
171 | of any other Contributor, and only if You agree to indemnify,
172 | defend, and hold each Contributor harmless for any liability
173 | incurred by, or claims asserted against, such Contributor by reason
174 | of your accepting any such warranty or additional liability.
175 |
176 | END OF TERMS AND CONDITIONS
177 |
178 | APPENDIX: How to apply the Apache License to your work.
179 |
180 | To apply the Apache License to your work, attach the following
181 | boilerplate notice, with the fields enclosed by brackets "[]"
182 | replaced with your own identifying information. (Don't include
183 | the brackets!) The text should be enclosed in the appropriate
184 | comment syntax for the file format. We also recommend that a
185 | file or class name and description of purpose be included on the
186 | same "printed page" as the copyright notice for easier
187 | identification within third-party archives.
188 |
189 | Copyright [yyyy] [name of copyright owner]
190 |
191 | Licensed under the Apache License, Version 2.0 (the "License");
192 | you may not use this file except in compliance with the License.
193 | You may obtain a copy of the License at
194 |
195 | http://www.apache.org/licenses/LICENSE-2.0
196 |
197 | Unless required by applicable law or agreed to in writing, software
198 | distributed under the License is distributed on an "AS IS" BASIS,
199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
200 | See the License for the specific language governing permissions and
201 | limitations under the License.
202 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Tact
2 |
10 |
11 | ## Building from source
12 |
13 | * Install `opam` using this [guide](https://ocaml.org/learn/tutorials/up_and_running.html)
14 | * Run following commands:
15 | ```
16 | opam init
17 | opam switch create $(pwd) --with-test -y
18 | eval $(opam env)
19 | dune build && dune install
20 | ```
21 |
22 | You can now use `tact /path/to/file.tact`
23 |
24 | ## Development instructions
25 |
26 | ### Updating dependencies
27 |
28 | Run `opam install . --working-dir --deps-only --with-test`
29 |
30 | ### Running REPL
31 |
32 | Run `dune utop lib`
33 |
34 | ### Running tests
35 |
36 | Run `dune test`
37 |
38 | ### Formatting code
39 |
40 | Run `dune build @fmt --auto-promote` (or no `--auto-promote` if you want to review changes, followed
41 | by `dune promote`)
42 |
43 | ### Working with expect-based tests
44 |
45 | `ppx_expect`
46 | [ppx_expect](https://github.com/janestreet/ppx_expect) tests allow to check output against an expectation
47 | and upon failure, they produce a diff, which can be easily applied to the original source code by running
48 | `dune promote` if the output is deemed to be correct. This allows us to write:
49 |
50 | ```ocaml
51 | pp source ; [%expect {||}]
52 | ```
53 |
54 | to fill in the blanks. In this particular case, it's useful to run `dune test --auto-promote`
55 |
56 | ### JavaScript bindings
57 |
58 | Can be built during `dune build` or `dune build js` and will be available in
59 | ` _build/default/js/tact_js.bc.js`
60 |
61 | In order to build a (smaller) release build, one should run:
62 |
63 | ```
64 | dune build js --profile=release
65 | ```
66 |
--------------------------------------------------------------------------------
/bin/dune:
--------------------------------------------------------------------------------
1 | (executable
2 | (public_name tact)
3 | (package tact)
4 | (name main)
5 | (modules main)
6 | (preprocess
7 | (pps ppx_blob))
8 | (libraries core tact linenoise base bos cmdliner ppx_blob))
9 |
--------------------------------------------------------------------------------
/bin/main.ml:
--------------------------------------------------------------------------------
1 | open Core
2 | open Bos
3 | module Show = Tact.Compiler.Show
4 | module Lang = Tact.Compiler.Lang
5 | module Syntax = Tact.Compiler.Syntax
6 | module Builtin = Tact.Compiler.Builtin
7 |
8 | let toolchain_available () =
9 | let exists f =
10 | match OS.Cmd.exists @@ Cmd.v f with Ok true -> true | _ -> false
11 | in
12 | match (exists "func", exists "fift") with
13 | | _, _ ->
14 | Option.is_some @@ Sys.getenv "FIFTPATH"
15 | | exception _ ->
16 | false
17 |
18 | let stdlib_fc = [%blob "stdlib.fc"]
19 |
20 | let compile ?(target = `Cell) filename program =
21 | let ext =
22 | match target with `Cell -> ".cell" | `Func -> ".fc" | `Fift -> ".fif"
23 | and is_func = match target with `Func -> true | _ -> false
24 | and is_fift = match target with `Fift -> true | _ -> false in
25 | let out_file =
26 | (Filename.chop_extension filename |> Filename.basename) ^ ext
27 | in
28 | if is_func then (
29 | ignore
30 | @@ OS.File.with_oc
31 | (Option.value_exn @@ Result.ok @@ Fpath.of_string out_file)
32 | (fun out () ->
33 | Stdio.Out_channel.(output_string out program ; flush out) ;
34 | Ok () )
35 | () ;
36 | Caml.Format.print_string ("Compiled to " ^ out_file) ;
37 | Caml.Format.print_newline () )
38 | else
39 | ignore
40 | @@ OS.File.with_tmp_oc
41 | (format_of_string "tact_%s")
42 | (fun path out () ->
43 | Stdio.Out_channel.(
44 | output_string out stdlib_fc ;
45 | output_string out program ;
46 | flush out ) ;
47 | let output =
48 | OS.Cmd.(
49 | run_out Cmd.(v "func" % "-APS" % Fpath.to_string path)
50 | |> to_string )
51 | in
52 | match output with
53 | | Ok fift ->
54 | let fift = fift ^ "\nboc>B \"" ^ out_file ^ "\" B>file\n" in
55 | ( if is_fift then
56 | ignore
57 | @@ OS.File.with_oc
58 | (Option.value_exn @@ Result.ok @@ Fpath.of_string out_file)
59 | (fun out () ->
60 | Stdio.Out_channel.(output_string out fift ; flush out) ;
61 | Ok () )
62 | ()
63 | else
64 | ignore
65 | @@ OS.Cmd.(in_string fift |> run_io Cmd.(v "fift") |> to_null)
66 | ) ;
67 | Caml.Format.print_string ("Compiled to " ^ out_file) ;
68 | Caml.Format.print_newline ()
69 | | _ ->
70 | Caml.Format.print_string "Failed to use the toolchain" ;
71 | Caml.Format.print_newline () )
72 | () ;
73 | ()
74 |
75 | let interpret_file ~target filename =
76 | match Tact.Compiler.compile_with_std ~filename (Caml.open_in filename) with
77 | | Ok program -> (
78 | let is_toolchain_available = toolchain_available () in
79 | match (is_toolchain_available, target) with
80 | | _, `Func ->
81 | compile ~target filename program
82 | | false, _ ->
83 | Caml.Format.print_string
84 | "Can't compile for this target without a toolchain"
85 | | true, target ->
86 | compile ~target filename program )
87 | | Error errors ->
88 | Caml.Format.print_string errors
89 |
90 | let prompt = "# "
91 |
92 | let default_program () =
93 | let program = Lang.default_program () in
94 | Result.ok_or_failwith @@ Result.map ~f:fst
95 | @@ Tact.Compiler.compile_to_ir' ~filename:"std.tact" ~prev_program:program
96 | Builtin.std
97 |
98 | let rec repl ?(program = default_program ()) ?(prompt = prompt) () =
99 | match LNoise.linenoise prompt with
100 | | None ->
101 | ()
102 | | Some input -> (
103 | let bindings = program#bindings in
104 | ignore @@ LNoise.history_add input ;
105 | match
106 | Tact.Compiler.eval_stmt ~constructor:program ~filename:"" input
107 | with
108 | | Ok result when not @@ Lang.equal_value result Void ->
109 | Show.pp_value Caml.Format.std_formatter result ;
110 | Caml.Format.print_newline () ;
111 | Caml.Format.print_flush () ;
112 | repl ~program ~prompt ()
113 | | Ok _ ->
114 | List.iter program#bindings ~f:(fun (name, value) ->
115 | if
116 | Option.is_none
117 | @@ List.find bindings ~f:(fun (name', value') ->
118 | Syntax.equal_located String.equal name name'
119 | && Syntax.equal_located Lang.equal_expr_kind value value' )
120 | then (
121 | Caml.Format.print_string @@ Syntax.value name ;
122 | Caml.Format.print_string " = " ;
123 | Show.pp_expr Caml.Format.std_formatter value ;
124 | Caml.Format.print_newline () ) ) ;
125 | Caml.Format.print_flush () ;
126 | repl ~program ~prompt ()
127 | | Error errors ->
128 | Caml.Format.print_string errors ;
129 | Caml.Format.print_flush () ;
130 | repl ~prompt () )
131 |
132 | open Cmdliner
133 |
134 | let tact target filename =
135 | match (target, filename) with
136 | | _, None ->
137 | LNoise.set_multiline true ;
138 | ignore @@ LNoise.history_set ~max_length:1000 ;
139 | repl ()
140 | | target, Some filename ->
141 | interpret_file ~target filename
142 |
143 | let tact_t =
144 | let target =
145 | let doc = "Output target [cell, func, fift] (ignored for REPL)" in
146 | Arg.(
147 | value
148 | & opt (enum [("cell", `Cell); ("func", `Func); ("fift", `Fift)]) `Cell
149 | & info ["t"; "target"] ~doc )
150 | and filename =
151 | let doc = "Input filename, if none given, will start REPL" in
152 | Arg.(
153 | value
154 | & pos ~rev:true 0 (some non_dir_file) None
155 | & info [] ~doc ~docv:"FILE" )
156 | in
157 | Term.(const tact $ target $ filename)
158 |
159 | let cmd =
160 | let doc = "compile Tact smart contract" in
161 | let info = Cmd.info "tact" ~doc in
162 | Cmd.v info tact_t
163 |
164 | let main () = exit (Cmd.eval cmd)
165 |
166 | let () = main ()
167 |
--------------------------------------------------------------------------------
/bin/stdlib.fc:
--------------------------------------------------------------------------------
1 | ;; Standard library for funC
2 | ;;
3 |
4 | forall X -> tuple cons(X head, tuple tail) asm "CONS";
5 | forall X -> (X, tuple) uncons(tuple list) asm "UNCONS";
6 | forall X -> (tuple, X) list_next(tuple list) asm( -> 1 0) "UNCONS";
7 | forall X -> X car(tuple list) asm "CAR";
8 | tuple cdr(tuple list) asm "CDR";
9 | tuple empty_tuple() asm "NIL";
10 | forall X -> tuple tpush(tuple t, X value) asm "TPUSH";
11 | forall X -> (tuple, ()) ~tpush(tuple t, X value) asm "TPUSH";
12 | forall X -> [X] single(X x) asm "SINGLE";
13 | forall X -> X unsingle([X] t) asm "UNSINGLE";
14 | forall X, Y -> [X, Y] pair(X x, Y y) asm "PAIR";
15 | forall X, Y -> (X, Y) unpair([X, Y] t) asm "UNPAIR";
16 | forall X, Y, Z -> [X, Y, Z] triple(X x, Y y, Z z) asm "TRIPLE";
17 | forall X, Y, Z -> (X, Y, Z) untriple([X, Y, Z] t) asm "UNTRIPLE";
18 | forall X, Y, Z, W -> [X, Y, Z, W] tuple4(X x, Y y, Z z, W w) asm "4 TUPLE";
19 | forall X, Y, Z, W -> (X, Y, Z, W) untuple4([X, Y, Z, W] t) asm "4 UNTUPLE";
20 | forall X -> X first(tuple t) asm "FIRST";
21 | forall X -> X second(tuple t) asm "SECOND";
22 | forall X -> X third(tuple t) asm "THIRD";
23 | forall X -> X fourth(tuple t) asm "3 INDEX";
24 | forall X, Y -> X pair_first([X, Y] p) asm "FIRST";
25 | forall X, Y -> Y pair_second([X, Y] p) asm "SECOND";
26 | forall X, Y, Z -> X triple_first([X, Y, Z] p) asm "FIRST";
27 | forall X, Y, Z -> Y triple_second([X, Y, Z] p) asm "SECOND";
28 | forall X, Y, Z -> Z triple_third([X, Y, Z] p) asm "THIRD";
29 | forall X -> X null() asm "PUSHNULL";
30 | forall X -> (X, ()) ~impure_touch(X x) impure asm "NOP";
31 |
32 | int now() asm "NOW";
33 | slice my_address() asm "MYADDR";
34 | [int, cell] get_balance() asm "BALANCE";
35 | int cur_lt() asm "LTIME";
36 | int block_lt() asm "BLOCKLT";
37 |
38 | int cell_hash(cell c) asm "HASHCU";
39 | int slice_hash(slice s) asm "HASHSU";
40 | int string_hash(slice s) asm "SHA256U";
41 |
42 | int check_signature(int hash, slice signature, int public_key) asm "CHKSIGNU";
43 | int check_data_signature(slice data, slice signature, int public_key) asm "CHKSIGNS";
44 |
45 | (int, int, int) compute_data_size(cell c, int max_cells) impure asm "CDATASIZE";
46 | (int, int, int) slice_compute_data_size(slice s, int max_cells) impure asm "SDATASIZE";
47 | (int, int, int, int) compute_data_size?(cell c, int max_cells) asm "CDATASIZEQ NULLSWAPIFNOT2 NULLSWAPIFNOT";
48 | (int, int, int, int) slice_compute_data_size?(cell c, int max_cells) asm "SDATASIZEQ NULLSWAPIFNOT2 NULLSWAPIFNOT";
49 |
50 | ;; () throw_if(int excno, int cond) impure asm "THROWARGIF";
51 |
52 | () dump_stack() impure asm "DUMPSTK";
53 |
54 | cell get_data() asm "c4 PUSH";
55 | () set_data(cell c) impure asm "c4 POP";
56 | cont get_c3() impure asm "c3 PUSH";
57 | () set_c3(cont c) impure asm "c3 POP";
58 | cont bless(slice s) impure asm "BLESS";
59 |
60 | () accept_message() impure asm "ACCEPT";
61 | () set_gas_limit(int limit) impure asm "SETGASLIMIT";
62 | () commit() impure asm "COMMIT";
63 | () buy_gas(int gram) impure asm "BUYGAS";
64 |
65 | int min(int x, int y) asm "MIN";
66 | int max(int x, int y) asm "MAX";
67 | (int, int) minmax(int x, int y) asm "MINMAX";
68 | int abs(int x) asm "ABS";
69 |
70 | slice begin_parse(cell c) asm "CTOS";
71 | () end_parse(slice s) impure asm "ENDS";
72 | (slice, cell) load_ref(slice s) asm( -> 1 0) "LDREF";
73 | cell preload_ref(slice s) asm "PLDREF";
74 | ;; (slice, int) ~load_int(slice s, int len) asm(s len -> 1 0) "LDIX";
75 | ;; (slice, int) ~load_uint(slice s, int len) asm( -> 1 0) "LDUX";
76 | ;; int preload_int(slice s, int len) asm "PLDIX";
77 | ;; int preload_uint(slice s, int len) asm "PLDUX";
78 | ;; (slice, slice) load_bits(slice s, int len) asm(s len -> 1 0) "LDSLICEX";
79 | ;; slice preload_bits(slice s, int len) asm "PLDSLICEX";
80 | (slice, int) load_grams(slice s) asm( -> 1 0) "LDGRAMS";
81 | slice skip_bits(slice s, int len) asm "SDSKIPFIRST";
82 | (slice, ()) ~skip_bits(slice s, int len) asm "SDSKIPFIRST";
83 | slice first_bits(slice s, int len) asm "SDCUTFIRST";
84 | slice skip_last_bits(slice s, int len) asm "SDSKIPLAST";
85 | (slice, ()) ~skip_last_bits(slice s, int len) asm "SDSKIPLAST";
86 | slice slice_last(slice s, int len) asm "SDCUTLAST";
87 | (slice, cell) load_dict(slice s) asm( -> 1 0) "LDDICT";
88 | cell preload_dict(slice s) asm "PLDDICT";
89 | slice skip_dict(slice s) asm "SKIPDICT";
90 |
91 | (slice, cell) load_maybe_ref(slice s) asm( -> 1 0) "LDOPTREF";
92 | cell preload_maybe_ref(slice s) asm "PLDOPTREF";
93 | builder store_maybe_ref(builder b, cell c) asm(c b) "STOPTREF";
94 |
95 | int cell_depth(cell c) asm "CDEPTH";
96 |
97 | int slice_refs(slice s) asm "SREFS";
98 | int slice_bits(slice s) asm "SBITS";
99 | (int, int) slice_bits_refs(slice s) asm "SBITREFS";
100 | int slice_empty?(slice s) asm "SEMPTY";
101 | int slice_data_empty?(slice s) asm "SDEMPTY";
102 | int slice_refs_empty?(slice s) asm "SREMPTY";
103 | int slice_depth(slice s) asm "SDEPTH";
104 |
105 | int builder_refs(builder b) asm "BREFS";
106 | int builder_bits(builder b) asm "BBITS";
107 | int builder_depth(builder b) asm "BDEPTH";
108 |
109 | builder begin_cell() asm "NEWC";
110 | cell end_cell(builder b) asm "ENDC";
111 | builder store_ref(builder b, cell c) asm(c b) "STREF";
112 | ;; builder store_uint(builder b, int x, int len) asm(x b len) "STUX";
113 | ;; builder store_int(builder b, int x, int len) asm(x b len) "STIX";
114 | builder store_slice(builder b, slice s) asm "STSLICER";
115 | builder store_grams(builder b, int x) asm "STGRAMS";
116 | builder store_dict(builder b, cell c) asm(c b) "STDICT";
117 |
118 | (slice, slice) load_msg_addr(slice s) asm( -> 1 0) "LDMSGADDR";
119 | tuple parse_addr(slice s) asm "PARSEMSGADDR";
120 | (int, int) parse_std_addr(slice s) asm "REWRITESTDADDR";
121 | (int, slice) parse_var_addr(slice s) asm "REWRITEVARADDR";
122 |
123 | cell idict_set_ref(cell dict, int key_len, int index, cell value) asm(value index dict key_len) "DICTISETREF";
124 | (cell, ()) ~idict_set_ref(cell dict, int key_len, int index, cell value) asm(value index dict key_len) "DICTISETREF";
125 | cell udict_set_ref(cell dict, int key_len, int index, cell value) asm(value index dict key_len) "DICTUSETREF";
126 | (cell, ()) ~udict_set_ref(cell dict, int key_len, int index, cell value) asm(value index dict key_len) "DICTUSETREF";
127 | cell idict_get_ref(cell dict, int key_len, int index) asm(index dict key_len) "DICTIGETOPTREF";
128 | (cell, int) idict_get_ref?(cell dict, int key_len, int index) asm(index dict key_len) "DICTIGETREF";
129 | (cell, int) udict_get_ref?(cell dict, int key_len, int index) asm(index dict key_len) "DICTUGETREF";
130 | (cell, cell) idict_set_get_ref(cell dict, int key_len, int index, cell value) asm(value index dict key_len) "DICTISETGETOPTREF";
131 | (cell, cell) udict_set_get_ref(cell dict, int key_len, int index, cell value) asm(value index dict key_len) "DICTUSETGETOPTREF";
132 | (cell, int) idict_delete?(cell dict, int key_len, int index) asm(index dict key_len) "DICTIDEL";
133 | (cell, int) udict_delete?(cell dict, int key_len, int index) asm(index dict key_len) "DICTUDEL";
134 | (slice, int) idict_get?(cell dict, int key_len, int index) asm(index dict key_len) "DICTIGET" "NULLSWAPIFNOT";
135 | (slice, int) udict_get?(cell dict, int key_len, int index) asm(index dict key_len) "DICTUGET" "NULLSWAPIFNOT";
136 | (cell, slice, int) idict_delete_get?(cell dict, int key_len, int index) asm(index dict key_len) "DICTIDELGET" "NULLSWAPIFNOT";
137 | (cell, slice, int) udict_delete_get?(cell dict, int key_len, int index) asm(index dict key_len) "DICTUDELGET" "NULLSWAPIFNOT";
138 | (cell, (slice, int)) ~idict_delete_get?(cell dict, int key_len, int index) asm(index dict key_len) "DICTIDELGET" "NULLSWAPIFNOT";
139 | (cell, (slice, int)) ~udict_delete_get?(cell dict, int key_len, int index) asm(index dict key_len) "DICTUDELGET" "NULLSWAPIFNOT";
140 | cell udict_set(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTUSET";
141 | (cell, ()) ~udict_set(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTUSET";
142 | cell idict_set(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTISET";
143 | (cell, ()) ~idict_set(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTISET";
144 | cell dict_set(cell dict, int key_len, slice index, slice value) asm(value index dict key_len) "DICTSET";
145 | (cell, ()) ~dict_set(cell dict, int key_len, slice index, slice value) asm(value index dict key_len) "DICTSET";
146 | (cell, int) udict_add?(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTUADD";
147 | (cell, int) udict_replace?(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTUREPLACE";
148 | (cell, int) idict_add?(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTIADD";
149 | (cell, int) idict_replace?(cell dict, int key_len, int index, slice value) asm(value index dict key_len) "DICTIREPLACE";
150 | cell udict_set_builder(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTUSETB";
151 | (cell, ()) ~udict_set_builder(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTUSETB";
152 | cell idict_set_builder(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTISETB";
153 | (cell, ()) ~idict_set_builder(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTISETB";
154 | cell dict_set_builder(cell dict, int key_len, slice index, builder value) asm(value index dict key_len) "DICTSETB";
155 | (cell, ()) ~dict_set_builder(cell dict, int key_len, slice index, builder value) asm(value index dict key_len) "DICTSETB";
156 | (cell, int) udict_add_builder?(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTUADDB";
157 | (cell, int) udict_replace_builder?(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTUREPLACEB";
158 | (cell, int) idict_add_builder?(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTIADDB";
159 | (cell, int) idict_replace_builder?(cell dict, int key_len, int index, builder value) asm(value index dict key_len) "DICTIREPLACEB";
160 | (cell, int, slice, int) udict_delete_get_min(cell dict, int key_len) asm(-> 0 2 1 3) "DICTUREMMIN" "NULLSWAPIFNOT2";
161 | (cell, (int, slice, int)) ~udict::delete_get_min(cell dict, int key_len) asm(-> 0 2 1 3) "DICTUREMMIN" "NULLSWAPIFNOT2";
162 | (cell, int, slice, int) idict_delete_get_min(cell dict, int key_len) asm(-> 0 2 1 3) "DICTIREMMIN" "NULLSWAPIFNOT2";
163 | (cell, (int, slice, int)) ~idict::delete_get_min(cell dict, int key_len) asm(-> 0 2 1 3) "DICTIREMMIN" "NULLSWAPIFNOT2";
164 | (cell, slice, slice, int) dict_delete_get_min(cell dict, int key_len) asm(-> 0 2 1 3) "DICTREMMIN" "NULLSWAPIFNOT2";
165 | (cell, (slice, slice, int)) ~dict::delete_get_min(cell dict, int key_len) asm(-> 0 2 1 3) "DICTREMMIN" "NULLSWAPIFNOT2";
166 | (cell, int, slice, int) udict_delete_get_max(cell dict, int key_len) asm(-> 0 2 1 3) "DICTUREMMAX" "NULLSWAPIFNOT2";
167 | (cell, (int, slice, int)) ~udict::delete_get_max(cell dict, int key_len) asm(-> 0 2 1 3) "DICTUREMMAX" "NULLSWAPIFNOT2";
168 | (cell, int, slice, int) idict_delete_get_max(cell dict, int key_len) asm(-> 0 2 1 3) "DICTIREMMAX" "NULLSWAPIFNOT2";
169 | (cell, (int, slice, int)) ~idict::delete_get_max(cell dict, int key_len) asm(-> 0 2 1 3) "DICTIREMMAX" "NULLSWAPIFNOT2";
170 | (cell, slice, slice, int) dict_delete_get_max(cell dict, int key_len) asm(-> 0 2 1 3) "DICTREMMAX" "NULLSWAPIFNOT2";
171 | (cell, (slice, slice, int)) ~dict::delete_get_max(cell dict, int key_len) asm(-> 0 2 1 3) "DICTREMMAX" "NULLSWAPIFNOT2";
172 | (int, slice, int) udict_get_min?(cell dict, int key_len) asm (-> 1 0 2) "DICTUMIN" "NULLSWAPIFNOT2";
173 | (int, slice, int) udict_get_max?(cell dict, int key_len) asm (-> 1 0 2) "DICTUMAX" "NULLSWAPIFNOT2";
174 | (int, cell, int) udict_get_min_ref?(cell dict, int key_len) asm (-> 1 0 2) "DICTUMINREF" "NULLSWAPIFNOT2";
175 | (int, cell, int) udict_get_max_ref?(cell dict, int key_len) asm (-> 1 0 2) "DICTUMAXREF" "NULLSWAPIFNOT2";
176 | (int, slice, int) idict_get_min?(cell dict, int key_len) asm (-> 1 0 2) "DICTIMIN" "NULLSWAPIFNOT2";
177 | (int, slice, int) idict_get_max?(cell dict, int key_len) asm (-> 1 0 2) "DICTIMAX" "NULLSWAPIFNOT2";
178 | (int, cell, int) idict_get_min_ref?(cell dict, int key_len) asm (-> 1 0 2) "DICTIMINREF" "NULLSWAPIFNOT2";
179 | (int, cell, int) idict_get_max_ref?(cell dict, int key_len) asm (-> 1 0 2) "DICTIMAXREF" "NULLSWAPIFNOT2";
180 | (int, slice, int) udict_get_next?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTUGETNEXT" "NULLSWAPIFNOT2";
181 | (int, slice, int) udict_get_nexteq?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTUGETNEXTEQ" "NULLSWAPIFNOT2";
182 | (int, slice, int) udict_get_prev?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTUGETPREV" "NULLSWAPIFNOT2";
183 | (int, slice, int) udict_get_preveq?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTUGETPREVEQ" "NULLSWAPIFNOT2";
184 | (int, slice, int) idict_get_next?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTIGETNEXT" "NULLSWAPIFNOT2";
185 | (int, slice, int) idict_get_nexteq?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTIGETNEXTEQ" "NULLSWAPIFNOT2";
186 | (int, slice, int) idict_get_prev?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTIGETPREV" "NULLSWAPIFNOT2";
187 | (int, slice, int) idict_get_preveq?(cell dict, int key_len, int pivot) asm(pivot dict key_len -> 1 0 2) "DICTIGETPREVEQ" "NULLSWAPIFNOT2";
188 | cell new_dict() asm "NEWDICT";
189 | int dict_empty?(cell c) asm "DICTEMPTY";
190 |
191 | (slice, slice, slice, int) pfxdict_get?(cell dict, int key_len, slice key) asm(key dict key_len) "PFXDICTGETQ" "NULLSWAPIFNOT2";
192 | (cell, int) pfxdict_set?(cell dict, int key_len, slice key, slice value) asm(value key dict key_len) "PFXDICTSET";
193 | (cell, int) pfxdict_delete?(cell dict, int key_len, slice key) asm(key dict key_len) "PFXDICTDEL";
194 |
195 | cell config_param(int x) asm "CONFIGOPTPARAM";
196 | int cell_null?(cell c) asm "ISNULL";
197 |
198 | () raw_reserve(int amount, int mode) impure asm "RAWRESERVE";
199 | () raw_reserve_extra(int amount, cell extra_amount, int mode) impure asm "RAWRESERVEX";
200 | () send_raw_message(cell msg, int mode) impure asm "SENDRAWMSG";
201 | () set_code(cell new_code) impure asm "SETCODE";
202 |
203 | int random() impure asm "RANDU256";
204 | int rand(int range) impure asm "RAND";
205 | int get_seed() impure asm "RANDSEED";
206 | int set_seed() impure asm "SETRAND";
207 | () randomize(int x) impure asm "ADDRAND";
208 | () randomize_lt() impure asm "LTIME" "ADDRAND";
209 |
--------------------------------------------------------------------------------
/dune-project:
--------------------------------------------------------------------------------
1 | (lang dune 2.9)
2 | (generate_opam_files true)
3 |
4 | (name tact)
5 | (source (github tact-lang/tact))
6 | (license Apache-2.0)
7 | (authors "cmxog@protonmail.com" "dmytro.polunin@gmail.com")
8 | (maintainers "cmxog@protonmail.com" "dmytro.polunin@gmail.com")
9 |
10 | (package
11 | (name tonvm)
12 | (synopsis "TON Virtual Machine implementation")
13 | (depends
14 | (ocaml (>= 4.14.0))
15 | (base (>= 0.15.0))
16 | (bitstring (>= 4.1.0))
17 | (ppx_bitstring (>= 4.1.0))
18 | (zarith (>= 1.12))
19 | (stdint (>= 0.7.0))
20 | (ppx_show (>= 0.2.1))
21 | (sexplib (>= 0.15.0))
22 | (ppx_sexp_conv (>= 0.15.1))
23 | (dune (and :build (>= 3.1.1)))
24 | (ppx_expect (and :with-test (>= 0.15.0)))))
25 |
26 | (package
27 | (name tact)
28 | (synopsis "TON Tact Language")
29 | (depends
30 | (ocaml (>= 4.14.0))
31 | (ppx_show (>= 0.2.1))
32 | (ppx_make (>= 0.3.0))
33 | (ppx_blob (>= 0.7.2))
34 | (js_of_ocaml-ppx (>= 4.0.0))
35 | (zarith_stubs_js (>= 0.15.0))
36 | (dune (and :build (>= 3.1.1)))
37 | (js_of_ocaml (>= 4.0.0))
38 | (mparser (>= 1.3))
39 | (zarith (>= 1.12))
40 | (base (>= 0.15.0))
41 | (ppx_jane (>= 0.15.0))
42 | (visitors (= 20210608))
43 | (containers (>= 3.8.0))
44 | (linenoise (>= 1.3.1))
45 | (bos (>= 0.2.1))
46 | (cmdliner (>= 1.1.1))
47 | (core (and :with-test (>= 0.15.0)))
48 | (ppx_expect (and :with-test (>= 0.15.0)))
49 | (ppx_matches (and :with-test (>= 0.1)))
50 | (alcotest (and :with-test (>= 1.5.0)))
51 | (ppx_inline_alcotest (and :with-test (>= 1.0.0)))
52 | (utop (and :build (>= 2.9.1)))
53 | (ocamlformat (and :build (= 0.23.0))))
54 | )
55 |
--------------------------------------------------------------------------------
/examples/wallet_v3.tact:
--------------------------------------------------------------------------------
1 | struct MsgBody {
2 | val subwallet: Uint32
3 | val valid_until: Uint32
4 | val seqno: Uint32
5 |
6 | @derive impl Deserialize {}
7 | }
8 |
9 | struct WalletState {
10 | val seqno: Uint32
11 | val subwallet: Uint32
12 | val public_key: Uint256
13 |
14 | @derive impl Deserialize {}
15 | @derive impl Serialize {}
16 | }
17 |
18 | struct NextMessage {
19 | val cell: RefCell
20 | val flags: SendRawMsgFlags
21 |
22 | @derive impl Deserialize {}
23 | }
24 |
25 | fn recv_internal(_: Slice) {}
26 |
27 | fn recv_external(input: Slice) {
28 | let {value as signed, slice} = SignedBody[MsgBody].deserialize(input);
29 | let state = WalletState.deserialize(Slice.parse(Globals.load_state())).value;
30 |
31 | let body = signed.verify_body(state.public_key);
32 |
33 | if (body.valid_until <= Globals.get_now()) { thrown(35) }
34 | if (body.seqno != state.seqno) { thrown(33) }
35 | if (body.subwallet != state.subwallet) { thrown(34) }
36 |
37 | builtin_accept_message();
38 |
39 | while (slice.refs_count() != 0) {
40 | let {value as next, slice as new_slice} = NextMessage.deserialize(slice);
41 | slice = new_slice;
42 | send_raw_msg(next.cell.inner, next.flags);
43 | }
44 |
45 | state.seqno = state.seqno + 1;
46 | let new_state = state.serialize(Builder.new()).build();
47 | Globals.save_state(new_state);
48 | }
49 |
--------------------------------------------------------------------------------
/js/dune:
--------------------------------------------------------------------------------
1 | (executable
2 | (name tact_js)
3 | (preprocess
4 | (pps js_of_ocaml-ppx))
5 | (libraries tact js_of_ocaml zarith_stubs_js)
6 | (modules tact_js)
7 | (modes js))
8 |
--------------------------------------------------------------------------------
/js/tact_js.ml:
--------------------------------------------------------------------------------
1 | open Js_of_ocaml
2 | open Base
3 |
4 | let _ =
5 | Js.export "Tact"
6 | (object%js (_self)
7 | method parse (src : Js.js_string Js.t) =
8 | let src = Js.to_string src in
9 | match Tact.Compiler.compile_from_string src with
10 | | Ok program ->
11 | Js.string program
12 | | Error errors ->
13 | Js_error.raise_ @@ Js_error.of_error
14 | @@ new%js Js.error_constr (Js.string errors)
15 | end )
16 |
--------------------------------------------------------------------------------
/lib/attributes.ml:
--------------------------------------------------------------------------------
1 | open Base
2 |
3 | module Make =
4 | functor
5 | (Config : Config.T)
6 | ->
7 | struct
8 | open Lang_types.Make (Config)
9 |
10 | open struct
11 | let bl = Config.builtin_located
12 |
13 | let derive_executor p binds _exprs = function
14 | | ImplAttrTarget {impl; self_ty} -> (
15 | match impl.mk_impl_interface.value with
16 | (* Serialize intf *)
17 | | ResolvedReference (_, {value = Value (Type (InterfaceType -1)); _})
18 | | Value (Type (InterfaceType -1)) ->
19 | let builder_ty =
20 | find_comptime "Builder" binds
21 | |> Option.value_exn |> Result.ok |> Option.value_exn
22 | |> expr_to_type p
23 | in
24 | let self_serializer =
25 | FunctionCall
26 | ( bl @@ Reference (bl "serializer", HoleType),
27 | [bl @@ Value (Type self_ty)],
28 | true )
29 | in
30 | let fun_body =
31 | bl
32 | @@ Return
33 | ( bl
34 | @@ FunctionCall
35 | ( bl @@ self_serializer,
36 | [ bl @@ Reference (bl "self", self_ty);
37 | bl @@ Reference (bl "b", builder_ty) ],
38 | false ) )
39 | in
40 | let function_signature =
41 | bl
42 | @@ { function_params =
43 | [(bl "self", self_ty); (bl "b", builder_ty)];
44 | function_is_type = false;
45 | function_returns = builder_ty;
46 | function_attributes = [] }
47 | in
48 | let method_ =
49 | bl
50 | @@ MkFunction
51 | (bl {function_signature; function_impl = Fn fun_body})
52 | in
53 | let impl =
54 | { mk_impl_interface = impl.mk_impl_interface;
55 | mk_impl_attributes = [];
56 | mk_impl_methods = [(bl "serialize", method_)] }
57 | in
58 | ImplAttrTarget {impl; self_ty}
59 | (* Deserialize intf *)
60 | | ResolvedReference (_, {value = Value (Type (InterfaceType -2)); _})
61 | | Value (Type (InterfaceType -2)) ->
62 | let slice_ty =
63 | find_comptime "Slice" binds
64 | |> Option.value_exn |> Result.ok |> Option.value_exn
65 | |> expr_to_type p
66 | in
67 | let load_result_f =
68 | find_comptime "LoadResult" binds
69 | |> Option.value_exn |> Result.ok |> Option.value_exn
70 | in
71 | let self_deserializer =
72 | FunctionCall
73 | ( bl @@ Reference (bl "deserializer", HoleType),
74 | [bl @@ Value (Type self_ty)],
75 | true )
76 | in
77 | let fun_body =
78 | bl
79 | @@ Return
80 | ( bl
81 | @@ FunctionCall
82 | ( bl @@ self_deserializer,
83 | [bl @@ Reference (bl "s", slice_ty)],
84 | false ) )
85 | in
86 | let ret_ty =
87 | TypeCall
88 | {func = load_result_f; args = [bl @@ Value (Type self_ty)]}
89 | in
90 | let function_signature =
91 | bl
92 | @@ { function_params = [(bl "s", slice_ty)];
93 | function_is_type = false;
94 | function_returns = ret_ty;
95 | function_attributes = [] }
96 | in
97 | let method_ =
98 | bl
99 | @@ MkFunction
100 | (bl {function_signature; function_impl = Fn fun_body})
101 | in
102 | let impl =
103 | { mk_impl_interface = impl.mk_impl_interface;
104 | mk_impl_attributes = [];
105 | mk_impl_methods = [(bl "deserialize", method_)] }
106 | in
107 | ImplAttrTarget {impl; self_ty}
108 | | _ ->
109 | raise
110 | (Errors.InternalCompilerError
111 | "Currently, only `Serialize` and `Deserialize` interfaces \
112 | are supported" ) )
113 | end
114 |
115 | let attr_executors = [("derive", derive_executor)]
116 | end
117 |
--------------------------------------------------------------------------------
/lib/codegen_func.ml:
--------------------------------------------------------------------------------
1 | open Base
2 |
3 | module Make =
4 | functor
5 | (Config : Config.T)
6 | ->
7 | struct
8 | module T = Lang_types.Make (Config)
9 | module F = Func
10 | include Errors
11 | open Config
12 |
13 | exception Invalid
14 |
15 | exception Unsupported
16 |
17 | class constructor (program : T.program) =
18 | object (self)
19 | val mutable struct_representations : (T.struct_ * F.type_) list = []
20 |
21 | val mutable fn_name_counter = 0
22 |
23 | val mutable functions : (T.function_ * F.function_) list = []
24 |
25 | val mutable helpers : F.function_ list = []
26 |
27 | method cg_Fn body = F.Fn (List.concat (Option.value_exn body))
28 |
29 | method build_Integer : Zint.t -> F.expr = fun i -> F.Integer i
30 |
31 | method cg_Let : _ -> F.stmt =
32 | fun bindings ->
33 | F.Vars
34 | (List.map bindings ~f:(fun (name, expr) ->
35 | let expr = self#cg_expr expr in
36 | (F.type_of expr, name, expr) ) )
37 |
38 | method cg_Assignment
39 | ({assignment_lvalue; assignment_expr; _} : T.assignment) =
40 | match assignment_lvalue.value with
41 | | T.ReferenceLvalue assignment_ident ->
42 | F.Assignment (value assignment_ident, self#cg_expr assignment_expr)
43 | | T.FieldAccessLvalue {ref; ref_ty; fields = [field_ident]} -> (
44 | let build_updating ~(tensor : int option) struct_ty field field_ty
45 | =
46 | match tensor with
47 | | None ->
48 | if field >= 16 then
49 | ice "Only structs with 16 or less fields are allowed" ;
50 | let fun_name = "update" ^ Int.to_string field in
51 | ( if
52 | not
53 | @@ List.exists helpers ~f:(fun x ->
54 | String.equal x.function_name fun_name )
55 | then
56 | let fn : F.function_ =
57 | { function_name = fun_name;
58 | function_forall = ["F"; "T"];
59 | function_body =
60 | AsmFn (Int.to_string field ^ " SETINDEX");
61 | function_args =
62 | [("t", UnknownTuple); ("elem", NamedType "F")];
63 | function_returns = F.NamedType "T";
64 | function_is_impure = false }
65 | in
66 | helpers <- fn :: helpers ) ;
67 | F.Assignment
68 | ( value ref,
69 | F.FunctionCall
70 | ( fun_name,
71 | [ F.FunctionCall
72 | ( "func_believe_me",
73 | [ Reference
74 | (ref.value, self#lang_type_to_type ref_ty)
75 | ],
76 | F.UnknownTuple );
77 | struct_ty ],
78 | field_ty ) )
79 | | Some _ ->
80 | ice "Updating tensor values is not supported by codegen."
81 | in
82 | match ref_ty with
83 | | StructType s -> (
84 | let s = T.Program.get_struct program s in
85 | match s.struct_fields with
86 | | [_] ->
87 | F.Assignment (value ref, self#cg_expr assignment_expr)
88 | | _ ->
89 | let field_id, (_, field) =
90 | Option.value_exn
91 | (List.findi s.struct_fields ~f:(fun _ (name, _) ->
92 | equal_string name.value field_ident.value ) )
93 | in
94 | build_updating
95 | ~tensor:
96 | ( if s.tensor then Some (List.length s.struct_fields)
97 | else None )
98 | (self#cg_expr assignment_expr)
99 | field_id
100 | (self#lang_type_to_type field.field_type) )
101 | | _ ->
102 | raise Invalid )
103 | | _ ->
104 | ice "Nested field updating is not supported by codegen"
105 |
106 | method cg_DestructuringLet : T.destructuring_let -> F.stmt =
107 | fun let_ ->
108 | let expr = let_.destructuring_let_expr in
109 | match T.type_of program expr with
110 | | StructType id ->
111 | let struct_ = T.Program.get_struct program id in
112 | let expr' = self#cg_expr expr in
113 | let fields =
114 | List.map struct_.struct_fields
115 | ~f:(fun (field_name, {field_type; _}) ->
116 | match
117 | List.Assoc.find let_.destructuring_let
118 | ~equal:(equal_located String.equal)
119 | field_name
120 | with
121 | | Some new_name ->
122 | ( Some (self#lang_type_to_type field_type),
123 | new_name.value )
124 | | None ->
125 | (None, "_") )
126 | in
127 | F.DestructuringBinding (fields, expr')
128 | | _x ->
129 | T.print_sexp (T.sexp_of_type_ _x) ;
130 | raise Invalid
131 |
132 | method cg_Struct : T.struct_ * (string * T.expr) list -> F.expr =
133 | function
134 | | _, [(_, expr)] ->
135 | self#cg_expr expr
136 | | _, args ->
137 | F.Tuple (List.map args ~f:(fun (_, expr) -> self#cg_expr expr))
138 |
139 | method cg_expr : T.expr -> F.expr =
140 | fun expr ->
141 | match expr.value with
142 | | Value (Integer i) ->
143 | F.Integer i
144 | | Value (Bool true) ->
145 | F.Integer (Zint.of_int (-1))
146 | | Value (Bool false) ->
147 | F.Integer Zint.zero
148 | | StructField x ->
149 | self#cg_StructField x
150 | | Value (Struct ({value = Value (Type (StructType id)); _}, inst))
151 | ->
152 | self#cg_Struct (T.Program.get_struct program id, inst)
153 | | ResolvedReference s ->
154 | self#cg_ResolvedReference s
155 | | Reference (name, ty) ->
156 | F.Reference (name.value, self#lang_type_to_type ty)
157 | | Primitive p ->
158 | self#cg_Primitive p
159 | | Value (Function f) ->
160 | let f' = self#add_function f in
161 | F.Reference (f'.function_name, F.FunctionType f')
162 | | FunctionCall (func, args, _is_ty) -> (
163 | (* TODO: if is_ty then ice "Type function in runtime context." ;*)
164 | let args = List.map args ~f:self#cg_expr in
165 | match self#cg_expr func with
166 | | Reference (name, F.FunctionType f) ->
167 | F.FunctionCall (name, args, f.function_returns)
168 | | _ ->
169 | raise Invalid )
170 | | MakeUnionVariant (expr, union) ->
171 | self#cg_union_variant expr union
172 | | Value (UnionVariant (v, u)) ->
173 | self#cg_union_variant {value = Value v; span = expr.span} u
174 | | _ ->
175 | (* T.print_sexp @@ T.sexp_of_expr expr ; *)
176 | raise Unsupported
177 |
178 | method cg_union_variant expr union =
179 | let e_ty = T.type_of program expr in
180 | let expr = self#cg_expr expr in
181 | let union =
182 | List.Assoc.find_exn program.unions union ~equal:equal_int
183 | in
184 | let (T.Discriminator {discr; _}) =
185 | List.Assoc.find_exn union.cases e_ty ~equal:T.equal_type_
186 | in
187 | F.Tuple [F.Integer (Z.of_int discr); expr]
188 | |> fun t -> F.FunctionCall ("func_believe_me", [t], F.UnknownTuple)
189 |
190 | method get_discriminator : T.union -> T.type_ -> int =
191 | fun union ty ->
192 | let (T.Discriminator {discr; _}) =
193 | List.Assoc.find_exn union.cases ty ~equal:T.equal_type_
194 | in
195 | discr
196 |
197 | method cg_stmt : T.stmt -> F.stmt =
198 | fun stmt ->
199 | match stmt.value with
200 | | Let bindings ->
201 | self#cg_Let
202 | @@ List.map bindings ~f:(fun (n, ex) -> (n.value, ex))
203 | | DestructuringLet let_ ->
204 | self#cg_DestructuringLet let_
205 | | Assignment assignment ->
206 | self#cg_Assignment assignment
207 | | Return expr ->
208 | F.Return (self#cg_expr expr)
209 | | Expr e ->
210 | F.Expr (self#cg_expr e)
211 | | Block stmts ->
212 | F.Block (List.map stmts ~f:self#cg_stmt)
213 | | If {if_condition; if_then; if_else} ->
214 | F.If
215 | ( self#cg_expr if_condition,
216 | self#cg_stmt if_then,
217 | Option.map if_else ~f:self#cg_stmt )
218 | | Break stmt ->
219 | self#cg_stmt stmt (* FIXME: this is unlikely to be correct *)
220 | | Switch s ->
221 | self#cg_switch s
222 | | WhileLoop {while_cond; while_body} ->
223 | F.While
224 | { cond = self#cg_expr while_cond;
225 | body = self#cg_stmt while_body }
226 | | _ ->
227 | raise Unsupported
228 |
229 | method cg_switch switch =
230 | let f_cond =
231 | F.Vars
232 | [(F.UnknownTuple, "temp", self#cg_expr switch.switch_condition)]
233 | in
234 | let f_discr =
235 | F.Vars
236 | [ ( F.IntType,
237 | "discr",
238 | F.FunctionCall
239 | ("first", [Reference ("temp", F.UnknownTuple)], F.IntType)
240 | ) ]
241 | in
242 | let union =
243 | match T.type_of program switch.switch_condition with
244 | | UnionType u ->
245 | List.Assoc.find_exn program.unions u ~equal:equal_int
246 | | _ ->
247 | ice "Type-check error"
248 | in
249 | let branches =
250 | List.fold (List.rev switch.branches)
251 | ~init:
252 | (F.Block
253 | [ F.Expr
254 | (F.FunctionCall
255 | ("thrown", [F.Integer (Z.of_int 90)], F.InferType) );
256 | F.Return
257 | (F.FunctionCall
258 | ("func_believe_me", [F.Tuple []], F.InferType) ) ] )
259 | ~f:(fun acc b ->
260 | let ty_discr = self#get_discriminator union b.value.branch_ty in
261 | let cond =
262 | F.Operator
263 | ( F.Reference ("discr", F.IntType),
264 | EqualityOperator,
265 | F.Integer (Z.of_int ty_discr) )
266 | in
267 | let inner =
268 | F.Block
269 | [ F.Vars
270 | [ ( self#lang_type_to_type b.value.branch_ty,
271 | b.value.branch_var.value,
272 | F.FunctionCall
273 | ( "second",
274 | [Reference ("temp", F.UnknownTuple)],
275 | F.IntType ) ) ];
276 | self#cg_stmt b.value.branch_stmt ]
277 | in
278 | F.Block [F.If (cond, inner, Some acc)] )
279 | in
280 | F.Block [f_cond; f_discr; branches]
281 |
282 | method cg_function_ : string -> T.function_ -> F.function_ =
283 | fun name fn ->
284 | let body =
285 | match fn.value.function_impl with
286 | | Fn {value = Block stmts; _}
287 | | UniversalFn ({value = Block stmts; _}, _) ->
288 | stmts
289 | | Fn stmt | UniversalFn (stmt, _) ->
290 | [stmt]
291 | | _ ->
292 | []
293 | in
294 | { function_forall = [];
295 | function_name = name;
296 | function_args =
297 | List.map fn.value.function_signature.value.function_params
298 | ~f:(fun (name, ty) -> (name.value, self#lang_type_to_type ty));
299 | function_returns =
300 | self#lang_type_to_type
301 | fn.value.function_signature.value.function_returns;
302 | function_body = F.Fn (List.map body ~f:self#cg_stmt);
303 | function_is_impure = true }
304 |
305 | method cg_top_level_stmt : string -> T.expr -> F.top_level_expr option =
306 | fun name expr ->
307 | match expr.value with
308 | | Value (Function f) -> (
309 | try Some (F.Function (self#add_function f ~name:(Some name)))
310 | with ex ->
311 | if equal_string name "test_req_builder" then raise ex else None
312 | )
313 | | _ ->
314 | None
315 |
316 | method cg_program : T.program -> F.program =
317 | fun program ->
318 | let _ =
319 | List.filter_map (List.rev program.bindings)
320 | ~f:(fun (name, top_level_stmt) ->
321 | self#cg_top_level_stmt name.value top_level_stmt )
322 | and make_tensor_accessors (sz : int) =
323 | let typeargs =
324 | List.map ~f:(fun i -> "Value" ^ Int.to_string i)
325 | @@ List.range ~start:`inclusive ~stop:`inclusive 1 sz
326 | in
327 | List.map ~f:(fun i ->
328 | let ret = List.nth_exn typeargs (i - 1)
329 | and tensor_type =
330 | F.TensorType
331 | (List.map typeargs ~f:(fun ident -> F.NamedType ident))
332 | in
333 | F.Function
334 | { function_forall = typeargs;
335 | function_name =
336 | "tensor" ^ Int.to_string sz ^ "_value" ^ Int.to_string i;
337 | function_args = [("tensor", tensor_type)];
338 | function_returns = NamedType ret;
339 | function_body =
340 | Fn
341 | [ DestructuringBinding
342 | ( List.mapi typeargs ~f:(fun i' typearg ->
343 | if Int.equal i (i' + 1) then
344 | (Some (F.NamedType typearg), "value")
345 | else (None, "_") ),
346 | Reference ("tensor", tensor_type) );
347 | Return (Reference ("value", NamedType ret)) ];
348 | function_is_impure = false } )
349 | @@ List.range ~start:`inclusive ~stop:`inclusive 1 sz
350 | and default_functions : F.top_level_expr list =
351 | [ { function_name = "func_believe_me";
352 | function_forall = ["A"; "B"];
353 | function_args = [("i", NamedType "A")];
354 | function_returns = NamedType "B";
355 | function_body = AsmFn "NOP";
356 | function_is_impure = false };
357 | { function_name = "func_bit_not";
358 | function_forall = [];
359 | function_args = [("a", IntType)];
360 | function_returns = IntType;
361 | function_body =
362 | Fn [Return (UnaryOp ("~", Reference ("a", IntType)))];
363 | function_is_impure = false } ]
364 | |> List.map ~f:(fun (x : F.function_) -> F.Function x)
365 | in
366 | make_tensor_accessors 2 @ default_functions
367 | @ List.map helpers ~f:(fun x -> F.Function x)
368 | @ List.map (List.rev functions) ~f:(fun (_, f) -> F.Function f)
369 | |> List.map ~f:(fun x ->
370 | match x with
371 | | F.Function f ->
372 | if String.equal f.function_name "believe_me" then
373 | F.Function
374 | { function_name = "believe_me";
375 | function_forall = ["A"; "B"];
376 | function_args = [("i", NamedType "A")];
377 | function_returns = NamedType "B";
378 | function_body = AsmFn "NOP";
379 | function_is_impure = false }
380 | else F.Function f
381 | | x ->
382 | x )
383 |
384 | method cg_StructField : T.expr * string located * T.type_ -> _ =
385 | fun (from_expr, field, _) ->
386 | let build_access ~(tensor : int option) struct_ty field field_ty =
387 | match tensor with
388 | | None ->
389 | if field >= 16 then
390 | ice "Only structs with 16 or less fields are allowed" ;
391 | let fun_name = "get" ^ Int.to_string field in
392 | ( if
393 | not
394 | @@ List.exists helpers ~f:(fun x ->
395 | String.equal x.function_name fun_name )
396 | then
397 | let fn : F.function_ =
398 | { function_name = fun_name;
399 | function_forall = ["A"];
400 | function_body = AsmFn (Int.to_string field ^ " INDEX");
401 | function_args = [("t", UnknownTuple)];
402 | function_returns = NamedType "A";
403 | function_is_impure = false }
404 | in
405 | helpers <- fn :: helpers ) ;
406 | let converted_value =
407 | F.FunctionCall ("func_believe_me", [struct_ty], UnknownTuple)
408 | in
409 | F.FunctionCall (fun_name, [converted_value], field_ty)
410 | | Some arity ->
411 | let name =
412 | "tensor" ^ Int.to_string arity ^ "_value"
413 | ^ Int.to_string (field + 1)
414 | in
415 | F.FunctionCall (name, [struct_ty], field_ty)
416 | in
417 | match T.type_of program from_expr with
418 | | StructType s -> (
419 | let s = T.Program.get_struct program s in
420 | match s.struct_fields with
421 | | [_] ->
422 | self#cg_expr from_expr
423 | | _ ->
424 | let field_id, (_, field) =
425 | Option.value_exn
426 | (List.findi s.struct_fields ~f:(fun _ (name, _) ->
427 | equal_string name.value field.value ) )
428 | in
429 | build_access
430 | ~tensor:
431 | ( if s.tensor then Some (List.length s.struct_fields)
432 | else None )
433 | (self#cg_expr from_expr) field_id
434 | (self#lang_type_to_type field.field_type) )
435 | | _ ->
436 | raise Invalid
437 |
438 | method cg_ResolvedReference : 'a. 'a * T.expr -> F.expr =
439 | fun (_, expr) -> self#cg_expr expr
440 |
441 | method cg_Primitive : T.primitive -> F.expr =
442 | function
443 | | Prim {name; exprs; out_ty} ->
444 | F.FunctionCall
445 | ( name,
446 | List.map exprs ~f:self#cg_expr,
447 | self#lang_type_to_type out_ty )
448 |
449 | method private lang_type_to_type : T.type_ -> F.type_ =
450 | function
451 | | IntegerType ->
452 | F.IntType
453 | | BoolType ->
454 | F.IntType
455 | | StructType s ->
456 | self#struct_to_ty (T.Program.get_struct program s)
457 | | UnionType _ ->
458 | F.UnknownTuple
459 | (* self#create_ty_from_union
460 | (List.Assoc.find_exn program.unions u ~equal:equal_int) *)
461 | | BuiltinType "Builder" ->
462 | F.BuilderType
463 | | BuiltinType "Cell" ->
464 | F.CellType
465 | | BuiltinType "Slice" ->
466 | F.SliceType
467 | | HoleType | VoidType ->
468 | F.InferType
469 | | _ ->
470 | raise Invalid
471 |
472 | method private struct_to_ty : T.struct_ -> F.type_ =
473 | fun s ->
474 | match
475 | List.find struct_representations ~f:(fun (s', _) ->
476 | T.equal_struct_ s s' )
477 | with
478 | | Some (_, ty) ->
479 | ty
480 | | None ->
481 | let ty = self#create_ty_from_struct s in
482 | struct_representations <- (s, ty) :: struct_representations ;
483 | ty
484 |
485 | method private create_ty_from_struct : T.struct_ -> F.type_ =
486 | function
487 | | {struct_fields = [(_, {field_type})]; _} ->
488 | self#lang_type_to_type field_type
489 | | {struct_fields; tensor; _} ->
490 | let types =
491 | List.map struct_fields ~f:(fun (_, {field_type}) ->
492 | self#lang_type_to_type field_type )
493 | in
494 | if tensor then TensorType types else TupleType types
495 |
496 | method private create_ty_from_union : T.union -> F.type_ =
497 | function _ -> UnknownTuple
498 |
499 | method private add_function
500 | : ?name:string option -> T.function_ -> F.function_ =
501 | fun ?(name = None) fn ->
502 | let default () =
503 | let name =
504 | Option.value_or_thunk name ~default:(fun () ->
505 | self#generate_func_name )
506 | in
507 | let fn' = self#cg_function_ name fn in
508 | functions <- (fn, fn') :: functions ;
509 | fn'
510 | in
511 | List.Assoc.find functions ~equal:T.equal_function_ fn
512 | |> Option.value_or_thunk ~default
513 |
514 | method private generate_func_name =
515 | let num = fn_name_counter in
516 | fn_name_counter <- fn_name_counter + 1 ;
517 | "f" ^ Printf.sprintf "%d" num
518 | end
519 |
520 | let codegen program =
521 | let constructor = new constructor program in
522 | constructor#cg_program program
523 | end
524 |
--------------------------------------------------------------------------------
/lib/compiler.ml:
--------------------------------------------------------------------------------
1 | (* Compiler frontend *)
2 |
3 | module Config = Located.Enabled
4 | module Lang = Lang.Make (Config)
5 | module Show = Show.Make (Config)
6 | module Syntax = Syntax.Make (Config)
7 | module Parser = Parser.Make (Config)
8 | module Codegen_func = Codegen_func.Make (Config)
9 | module Builtin = Builtin.Make (Config)
10 |
11 | let rec compile ?(codegen_impl = Codegen_func.codegen) ?(filename = "")
12 | ch =
13 | let text = really_input_string ch (in_channel_length ch) in
14 | close_in ch ;
15 | compile_from_string ~codegen_impl ~filename text
16 |
17 | and compile_from_string ?(codegen_impl = Codegen_func.codegen)
18 | ?(filename = "") src =
19 | codegen ~codegen_impl (compile_to_ir ~filename src)
20 |
21 | and codegen ?(codegen_impl = Codegen_func.codegen) program =
22 | match program with
23 | | Ok program' ->
24 | let generated_code = codegen_impl program' and buffer = Buffer.create 0 in
25 | let formatter = Caml.Format.formatter_of_buffer buffer in
26 | Func.pp_program formatter generated_code ;
27 | Ok (Buffer.contents buffer)
28 | | Error e ->
29 | Error e
30 |
31 | and eval_stmt ~(constructor : _ Lang.constructor) ~filename text =
32 | ignore filename ;
33 | match
34 | MParser.(
35 | parse_string
36 | Parser.(
37 | handle_errors
38 | ( attempt (locate stmt)
39 | <|> ( locate expr
40 | |>> fun s -> Syntax.map_located s ~f:(fun _ -> Syntax.Expr s) )
41 | <|> locate (return (Syntax.CodeBlock []))
42 | <<< eof ) ) )
43 | text ()
44 | with
45 | | Success stx -> (
46 | let errors = constructor#get_errors in
47 | let result =
48 | try
49 | let stmt =
50 | constructor#visit_located constructor#visit_stmt Lang.default_ctx
51 | stx
52 | in
53 | (constructor#make_interpreter stmt.span)#interpret_stmt
54 | (Syntax.map_located
55 | ~f:(function Lang.Expr e -> Lang.Return e | stmt -> stmt)
56 | stmt )
57 | []
58 | with Lang.Skip -> Void
59 | in
60 | match errors#to_result () with
61 | | Error _ ->
62 | Error (errors#show_errors text)
63 | | Ok _ ->
64 | Ok result )
65 | | MParser.Failed (msg, _) ->
66 | Error msg
67 |
68 | and construct ?(prev_program = Lang.default_program ()) ~filename text =
69 | ignore filename ;
70 | let stx = Parser.parse text in
71 | let errors = new Errors.errors Show.show_error in
72 | (stx, new Lang.constructor ~program:prev_program errors)
73 |
74 | and compile_to_ir' ?(prev_program = Lang.default_program ()) ~filename text =
75 | match construct ~prev_program ~filename text with
76 | | stx, constructor -> (
77 | let program = constructor#visit_program Lang.default_ctx stx in
78 | let errors = constructor#get_errors in
79 | match errors#to_result () with
80 | | Error _ ->
81 | Error (errors#show_errors text)
82 | | Ok _ ->
83 | Ok (constructor, program) )
84 | | exception Parser.Error (msg, _) ->
85 | Error msg
86 |
87 | and compile_to_ir ?(prev_program = Lang.default_program ()) ~filename text =
88 | Result.map snd @@ compile_to_ir' ~prev_program ~filename text
89 |
90 | let compile_with_std ?(codegen_impl = Codegen_func.codegen)
91 | ?(filename = "") ch =
92 | let prev_program =
93 | compile_to_ir ~filename:"std.tact" Builtin.std |> Result.get_ok
94 | in
95 | let text = really_input_string ch (in_channel_length ch) in
96 | close_in ch ;
97 | codegen ~codegen_impl (compile_to_ir ~prev_program ~filename text)
98 |
--------------------------------------------------------------------------------
/lib/config.ml:
--------------------------------------------------------------------------------
1 | module type T = sig
2 | include Located.T
3 | end
4 |
--------------------------------------------------------------------------------
/lib/discriminator.ml:
--------------------------------------------------------------------------------
1 | open Base
2 |
3 | module Make =
4 | functor
5 | (Config : Config.T)
6 | ->
7 | struct
8 | open Lang_types.Make (Config)
9 |
10 | module LocalDiscriminators = struct
11 | type t = unit
12 |
13 | open struct
14 | let get_discr_from_attrs attrs =
15 | List.find_map attrs ~f:(fun {attribute_ident; attribute_exprs} ->
16 | match (attribute_ident.value, attribute_exprs) with
17 | | "discriminator", [{value = Value (Integer x); _}] ->
18 | Some (Discriminator {discr = Z.to_int x; bits = None})
19 | | ( "discriminator",
20 | [ {value = Value (Integer x); _};
21 | {value = Value (Integer bits); _} ] ) ->
22 | Some
23 | (Discriminator
24 | {discr = Z.to_int x; bits = Some (Z.to_int bits)} )
25 | | _ ->
26 | None )
27 | end
28 |
29 | let choose_discriminators :
30 | t ->
31 | int ->
32 | (type_ * attribute list) list ->
33 | (type_ * discriminator) list =
34 | fun _ _ cases ->
35 | List.mapi (List.rev cases) ~f:(fun id (case, attrs) ->
36 | ( case,
37 | Option.value_or_thunk (get_discr_from_attrs attrs)
38 | ~default:(fun _ -> Discriminator {discr = id; bits = None}) ) )
39 | |> List.rev
40 | end
41 | end
42 |
--------------------------------------------------------------------------------
/lib/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (libraries
3 | base
4 | ppx_show.runtime
5 | zarith
6 | visitors.runtime
7 | ppx_sexp_conv
8 | sexplib
9 | containers
10 | mparser)
11 | (preprocess
12 | (pps
13 | ppx_show
14 | ppx_make
15 | ppx_compare
16 | visitors.ppx
17 | ppx_sexp_conv
18 | ppx_blob
19 | ppx_hash))
20 | (preprocessor_deps
21 | (file std/std.tact))
22 | (name tact))
23 |
--------------------------------------------------------------------------------
/lib/errors.ml:
--------------------------------------------------------------------------------
1 | open Base
2 |
3 | exception InternalCompilerError of string
4 |
5 | let unreachable () = raise (InternalCompilerError "unreachable")
6 |
7 | let ice msg = raise (InternalCompilerError msg)
8 |
9 | class ['a, 's, 'e, 'm] errors (show_error : string -> 'e -> string) =
10 | object (s : _)
11 | val mutable errors = []
12 |
13 | val show_error = show_error
14 |
15 | method report : 's -> 'e -> 'm -> unit =
16 | fun severity error meta -> errors <- (severity, error, meta) :: errors
17 |
18 | method errors = List.rev errors
19 |
20 | method to_result : 'a -> ('a, _) Result.t =
21 | fun value -> if List.is_empty errors then Ok value else Error s#errors
22 |
23 | method show_errors code =
24 | List.fold_left (List.rev errors) ~init:"" ~f:(fun s (_, e, _) ->
25 | s ^ show_error code e ^ "\n" )
26 | end
27 |
--------------------------------------------------------------------------------
/lib/func.ml:
--------------------------------------------------------------------------------
1 | open Base
2 |
3 | exception Unsupported
4 |
5 | (* Subset of FunC used by FunC codegen *)
6 |
7 | type function_ =
8 | { function_name : ident;
9 | function_args : (ident * type_) list;
10 | function_returns : type_;
11 | function_body : function_body;
12 | function_forall : ident list;
13 | function_is_impure : bool }
14 |
15 | and function_body = AsmFn of string | Fn of stmt list [@sexp.list]
16 |
17 | and stmt =
18 | | Vars of (type_ * ident * expr) list
19 | | DestructuringBinding of (type_ option * ident) list * expr
20 | | Assignment of (ident * expr)
21 | | Return of expr
22 | | Expr of expr
23 | | Block of stmt list
24 | | If of (expr * stmt * stmt option)
25 | | While of {cond : expr; body : stmt}
26 |
27 | and expr =
28 | | Integer of Zint.t
29 | | Reference of (ident * type_)
30 | | Tuple of expr list
31 | | FunctionCall of (ident * expr list * type_)
32 | | Operator of (expr * operator * expr)
33 | | UnaryOp of (string * expr)
34 |
35 | and operator = EqualityOperator
36 |
37 | and ident = string
38 |
39 | and type_ =
40 | | IntType
41 | | CellType
42 | | SliceType
43 | | BuilderType
44 | | TupleType of type_ list
45 | | UnknownTuple
46 | | TensorType of type_ list
47 | | FunctionType of function_
48 | | ContType
49 | | InferType
50 | | NamedType of ident
51 |
52 | and top_level_expr = Function of function_ | Global of type_ * ident
53 |
54 | and program = top_level_expr list [@@deriving sexp_of]
55 |
56 | exception UnknownType
57 |
58 | let rec type_of = function
59 | | Integer _ ->
60 | IntType
61 | | Reference (_, ty) ->
62 | ty
63 | | Tuple exprs ->
64 | TupleType (List.map exprs ~f:type_of)
65 | | FunctionCall (_, _, ty) ->
66 | ty
67 | | Operator (_, EqualityOperator, _) ->
68 | IntType
69 | | UnaryOp (_, _) ->
70 | IntType
71 |
72 | open Caml.Format
73 |
74 | let list_iter ~f ~flast l =
75 | match (List.drop_last l, List.last l) with
76 | | Some rest, Some last ->
77 | List.iter rest ~f ; flast last
78 | | _ ->
79 | ()
80 |
81 | let indentation = " "
82 |
83 | open struct
84 | let string_repeat s n =
85 | let s = Bytes.of_string s in
86 | let len = Bytes.length s in
87 | let res = Bytes.create (n * len) in
88 | for i = 0 to Int.pred n do
89 | Bytes.blit ~src:s ~src_pos:0 ~dst:res ~dst_pos:(i * len) ~len
90 | done ;
91 | Bytes.to_string res
92 | end
93 |
94 | let pp_indentation f level = pp_print_string f (string_repeat " " (level * 2))
95 |
96 | let boxed ?(box_size = 2) f ~func =
97 | pp_open_box f box_size ; func f ; pp_close_box f ()
98 |
99 | let rec pp_program f program =
100 | let prev_margin = pp_get_margin f () in
101 | let prev_indent = pp_get_max_indent f () in
102 | pp_set_margin f 80 ;
103 | pp_set_max_indent f 40 ;
104 | List.iter program ~f:(function
105 | | Function fn ->
106 | pp_function 0 f fn ; pp_print_newline f ()
107 | | Global _ ->
108 | () ) ;
109 | pp_set_margin f prev_margin ;
110 | pp_set_max_indent f prev_indent
111 |
112 | and pp_function level f fn =
113 | pp_open_box f 2 ;
114 | ( match fn.function_forall with
115 | | [] ->
116 | ()
117 | | typeargs ->
118 | pp_print_string f "forall" ;
119 | pp_print_space f () ;
120 | list_iter typeargs
121 | ~f:(fun ident -> pp_ident f ident ; pp_print_string f ", ")
122 | ~flast:(pp_ident f) ;
123 | pp_print_space f () ;
124 | pp_print_string f "->" ;
125 | pp_print_space f () ) ;
126 | pp_type f fn.function_returns ;
127 | pp_print_space f () ;
128 | pp_ident f fn.function_name ;
129 | pp_print_string f "(" ;
130 | list_iter fn.function_args
131 | ~f:(fun (name, t) ->
132 | pp_type f t ;
133 | pp_print_space f () ;
134 | pp_ident f name ;
135 | pp_print_string f ", " )
136 | ~flast:(fun (name, t) -> pp_type f t ; pp_print_space f () ; pp_ident f name) ;
137 | pp_print_string f ")" ;
138 | pp_print_space f () ;
139 | if fn.function_is_impure then (
140 | pp_print_string f "impure" ; pp_print_space f () ) ;
141 | pp_function_body (level + 1) f fn.function_body ;
142 | pp_close_box f ()
143 |
144 | and pp_function_body level f = function
145 | | Fn stmts ->
146 | pp_print_string f "{" ;
147 | pp_print_newline f () ;
148 | List.iter stmts ~f:(fun stmt ->
149 | pp_indentation f level ;
150 | pp_open_box f 2 ;
151 | pp_stmt level f stmt ;
152 | pp_close_box f () ) ;
153 | pp_print_string f "}"
154 | | AsmFn str ->
155 | pp_print_string f "asm" ;
156 | pp_print_space f () ;
157 | pp_print_string f @@ "\"" ^ str ^ "\"" ;
158 | pp_print_string f ";"
159 |
160 | and pp_stmt level f = function
161 | | Vars vars ->
162 | List.iter vars ~f:(fun (t, n, expr) ->
163 | boxed f ~func:(fun f ->
164 | pp_type f t ;
165 | pp_print_space f () ;
166 | pp_ident f n ;
167 | pp_print_space f () ;
168 | pp_print_string f "=" ;
169 | pp_print_space f () ;
170 | pp_expr f expr ;
171 | pp_print_string f ";" ;
172 | pp_close_box f () ;
173 | pp_print_newline f () ) )
174 | | DestructuringBinding (vars, expr) ->
175 | let tensor =
176 | match expr with Reference (_, TensorType _) -> true | _ -> false
177 | in
178 | boxed f ~func:(fun f ->
179 | pp_print_string f (if tensor then "(" else "[") ;
180 | list_iter vars
181 | ~f:(fun (t, n) ->
182 | ( match t with
183 | | Some t ->
184 | pp_type f t ; pp_print_space f ()
185 | | None ->
186 | () ) ;
187 | pp_ident f n ; pp_print_string f "," ; pp_print_space f () )
188 | ~flast:(fun (t, n) ->
189 | ( match t with
190 | | Some t ->
191 | pp_type f t ; pp_print_space f ()
192 | | None ->
193 | () ) ;
194 | pp_ident f n ) ;
195 | pp_print_string f (if tensor then ")" else "]") ;
196 | pp_print_space f () ;
197 | pp_print_string f "=" ;
198 | pp_print_space f () ;
199 | pp_expr f expr ;
200 | pp_print_string f ";" ;
201 | pp_print_newline f () )
202 | | Assignment (ident, expr) ->
203 | boxed f ~func:(fun f ->
204 | pp_ident f ident ;
205 | pp_print_space f () ;
206 | pp_print_string f "=" ;
207 | pp_print_space f () ;
208 | pp_expr f expr ;
209 | pp_print_string f ";" ;
210 | pp_print_newline f () )
211 | | Return expr ->
212 | boxed f ~func:(fun f ->
213 | pp_print_string f "return" ;
214 | pp_print_space f () ;
215 | pp_expr f expr ;
216 | pp_print_string f ";" ;
217 | pp_print_newline f () )
218 | | Expr expr ->
219 | pp_expr f expr ; pp_print_string f ";" ; pp_print_newline f ()
220 | | Block [stmt] ->
221 | pp_print_string f "{" ;
222 | pp_print_newline f () ;
223 | boxed f ~func:(fun f ->
224 | pp_indentation f (level + 1) ;
225 | pp_stmt (level + 1) f stmt ) ;
226 | pp_indentation f level ;
227 | pp_print_string f "}" ;
228 | pp_print_newline f ()
229 | | Block stmts ->
230 | pp_print_string f "{" ;
231 | pp_print_newline f () ;
232 | boxed f ~func:(fun f ->
233 | List.iter stmts ~f:(fun x ->
234 | pp_indentation f (level + 1) ;
235 | pp_stmt (level + 1) f x ) ) ;
236 | pp_indentation f level ;
237 | pp_print_string f "}" ;
238 | pp_print_newline f ()
239 | | If (condition, then_, else_) ->
240 | boxed f ~func:(fun f ->
241 | pp_print_string f "if" ;
242 | pp_print_space f () ;
243 | pp_print_string f "(" ;
244 | pp_expr f condition ;
245 | pp_print_string f ")" ;
246 | pp_print_space f () ;
247 | pp_stmt level f then_ ;
248 | Option.iter else_ ~f:(fun e ->
249 | boxed f ~func:(fun f ->
250 | pp_indentation f level ;
251 | pp_print_string f "else" ;
252 | pp_print_space f () ;
253 | pp_stmt level f e ) ) )
254 | | While {cond; body} ->
255 | pp_print_string f "while" ;
256 | pp_print_space f () ;
257 | pp_print_string f "(" ;
258 | pp_expr f cond ;
259 | pp_print_string f ")" ;
260 | pp_print_space f () ;
261 | pp_stmt (level + 1) f body
262 |
263 | and pp_expr f = function
264 | | Integer i ->
265 | pp_print_string f (Zint.to_string i)
266 | | Reference (ref, _) ->
267 | pp_ident f ref
268 | | FunctionCall (name, args, _) ->
269 | pp_print_string f name ;
270 | pp_print_string f "(" ;
271 | list_iter args
272 | ~f:(fun t -> pp_expr f t ; pp_print_string f ", ")
273 | ~flast:(pp_expr f) ;
274 | pp_print_string f ")"
275 | | Tuple tuple ->
276 | pp_print_string f "[" ;
277 | list_iter tuple
278 | ~f:(fun t -> pp_expr f t ; pp_print_string f ", ")
279 | ~flast:(pp_expr f) ;
280 | pp_print_string f "]"
281 | | Operator (left, op, right) ->
282 | pp_expr f left ;
283 | pp_print_space f () ;
284 | pp_operator f op ;
285 | pp_print_space f () ;
286 | pp_expr f right
287 | | UnaryOp (op, expr) ->
288 | pp_print_string f op ; pp_print_space f () ; pp_expr f expr
289 |
290 | and pp_operator f = function EqualityOperator -> pp_print_string f "=="
291 |
292 | and pp_type f = function
293 | | IntType ->
294 | pp_print_string f "int"
295 | | CellType ->
296 | pp_print_string f "cell"
297 | | SliceType ->
298 | pp_print_string f "slice"
299 | | BuilderType ->
300 | pp_print_string f "builder"
301 | | ContType ->
302 | pp_print_string f "cont"
303 | | TupleType tuple ->
304 | pp_print_string f "[" ;
305 | list_iter tuple
306 | ~f:(fun (t : type_) -> pp_type f t ; pp_print_string f ", ")
307 | ~flast:(pp_type f) ;
308 | pp_print_string f "]"
309 | | UnknownTuple ->
310 | pp_print_string f "tuple"
311 | | TensorType tuple ->
312 | pp_print_string f "(" ;
313 | list_iter tuple
314 | ~f:(fun t -> pp_type f t ; pp_print_string f ", ")
315 | ~flast:(pp_type f) ;
316 | pp_print_string f ")"
317 | | InferType ->
318 | pp_print_string f "_"
319 | | FunctionType _ ->
320 | raise UnknownType
321 | | NamedType name ->
322 | pp_print_string f name
323 |
324 | and pp_ident f i =
325 | match i with
326 | | "int" | "cell" | "slice" | "builder" | "cont" | "tuple " ->
327 | pp_print_string f (i ^ "_")
328 | | _ ->
329 | pp_print_string f i
330 |
--------------------------------------------------------------------------------
/lib/located.ml:
--------------------------------------------------------------------------------
1 | module Lexing' = struct
2 | open Base
3 | open Caml.Format
4 |
5 | let equal_string = String.equal
6 |
7 | let equal_int = Int.equal
8 |
9 | include Lexing
10 |
11 | let equal_position p1 p2 =
12 | String.equal p1.pos_fname p2.pos_fname
13 | && equal p1.pos_lnum p2.pos_lnum
14 | && equal p1.pos_bol p2.pos_bol
15 | && equal p1.pos_cnum p2.pos_cnum
16 |
17 | let sexp_of_position _pos = Sexplib.Sexp.(Atom "pos")
18 |
19 | type pos = position [@@deriving equal, sexp_of]
20 |
21 | let pp_pos f p =
22 | pp_print_string f p.pos_fname ;
23 | pp_print_string f ":" ;
24 | pp_print_int f p.pos_lnum ;
25 | pp_print_string f "," ;
26 | pp_print_int f p.pos_cnum
27 | end
28 |
29 | type pos = Lexing'.pos [@@deriving show {with_path = false}, equal]
30 |
31 | let sexp_of_pos = Lexing'.sexp_of_pos
32 |
33 | type span_concrete = pos * pos [@@deriving show, equal, sexp_of]
34 |
35 | let merge_spans_concrete : span_concrete -> span_concrete -> span_concrete =
36 | fun (s1, _) (_, e2) -> (s1, e2)
37 |
38 | let merge_spans_concrete_list list =
39 | let open Base in
40 | match list with
41 | | [] ->
42 | (Lexing'.dummy_pos, Lexing'.dummy_pos)
43 | | _ ->
44 | let hd = List.hd_exn list in
45 | let tl = List.tl_exn list in
46 | let rec merge_spans_list_inner left = function
47 | | [] ->
48 | left
49 | | x :: xs ->
50 | merge_spans_list_inner (merge_spans_concrete left x) xs
51 | in
52 | merge_spans_list_inner hd tl
53 |
54 | module type T = sig
55 | type span
56 |
57 | type 'a located = {span : span; value : 'a}
58 |
59 | val pp_located :
60 | (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a located -> unit
61 |
62 | val make_located : span:span_concrete -> value:'a -> unit -> 'a located
63 |
64 | val equal_located : ('a -> 'a -> bool) -> 'a located -> 'a located -> bool
65 |
66 | val hash_fold_located :
67 | (Base_internalhash_types.state -> 'a -> Base_internalhash_types.state) ->
68 | Base_internalhash_types.state ->
69 | 'a located ->
70 | Base_internalhash_types.state
71 |
72 | val compare_located : ('a -> 'a -> int) -> 'a located -> 'a located -> int
73 |
74 | val sexp_of_located : ('a -> Sexplib0.Sexp.t) -> 'a located -> Sexplib0.Sexp.t
75 |
76 | val value : 'a located -> 'a
77 |
78 | val span : 'a located -> span
79 |
80 | val pp_span : Format.formatter -> span -> unit
81 |
82 | val make_loc : 'a 'b. f:('a -> 'b) -> 'a located -> 'b located
83 |
84 | val builtin_located : 'a -> 'a located
85 |
86 | val merge_spans : span -> span -> span
87 |
88 | val merge_spans_list : span list -> span
89 |
90 | val span_of_concrete : span_concrete -> span
91 |
92 | val span_to_concrete : span -> span_concrete
93 |
94 | val map_located : 'a 'b. f:('a -> 'b) -> 'a located -> 'b located
95 | end
96 |
97 | module Enabled : T = struct
98 | type span = span_concrete
99 |
100 | type 'a located = {span : span_concrete; [@hash.ignore] value : 'a}
101 | [@@deriving show {with_path = false}, make, sexp_of, hash]
102 |
103 | let equal_located f {value = value1; _} {value = value2; _} = f value1 value2
104 |
105 | let compare_located f {value = value1; _} {value = value2; _} =
106 | f value1 value2
107 |
108 | let value l = l.value
109 |
110 | let span l = l.span
111 |
112 | let pp_span = pp_span_concrete
113 |
114 | let make_loc ~f l = {span = l.span; value = f l.value}
115 |
116 | let builtin_located a =
117 | {span = (Lexing'.dummy_pos, Lexing'.dummy_pos); value = a}
118 |
119 | let merge_spans = merge_spans_concrete
120 |
121 | let merge_spans_list = merge_spans_concrete_list
122 |
123 | let span_of_concrete s = s
124 |
125 | let span_to_concrete s = s
126 |
127 | let map_located ~f {span; value} = {span; value = f value}
128 | end
129 |
130 | module Disabled : T = struct
131 | open Base.Hash.Builtin
132 |
133 | type span = unit
134 |
135 | type 'a located = {span : unit; value : 'a} [@@deriving show, hash]
136 |
137 | let sexp_of_located f l = f l.value
138 |
139 | let make_located ~span:_span ~value () = {span = (); value}
140 |
141 | let equal_located f v1 v2 = f v1.value v2.value
142 |
143 | let compare_located f v1 v2 = f v1.value v2.value
144 |
145 | let value v = v.value
146 |
147 | let span _ = ()
148 |
149 | let pp_span _ _ = ()
150 |
151 | let make_loc ~f l = {span = l.span; value = f l.value}
152 |
153 | let builtin_located a = {span = (); value = a}
154 |
155 | let merge_spans _ _ = ()
156 |
157 | let merge_spans_list _ = ()
158 |
159 | let span_of_concrete _ = ()
160 |
161 | let span_to_concrete _ = (Lexing'.dummy_pos, Lexing'.dummy_pos)
162 |
163 | let map_located ~f {span; value; _} = {span; value = f value}
164 | end
165 |
--------------------------------------------------------------------------------
/lib/partial_evaluator.ml:
--------------------------------------------------------------------------------
1 | open Base
2 | open Errors
3 |
4 | module Make =
5 | functor
6 | (Config : Config.T)
7 | ->
8 | struct
9 | open Config
10 |
11 | open Interpreter.Make (Config)
12 |
13 | open Lang_types.Make (Config)
14 |
15 | class ['s] partial_evaluator (ctx : ctx) (errors : _) =
16 | object (self : 's)
17 | inherit [_] map as super
18 |
19 | (* Make a deep copy of the ctx. Local values should not flow into
20 | code that call partial_evaluator. *)
21 | val mutable ctx = {ctx with program = ctx.program}
22 |
23 | method! visit_InvalidType _ _ = unreachable ()
24 |
25 | method! visit_Reference env (ref, ty) =
26 | match find_in_scope ref.value !(ctx.scope) with
27 | | Some (Comptime ex) ->
28 | Value
29 | (self#with_interpreter env ref.span (fun inter ->
30 | inter#interpret_expr ex ) )
31 | | Some (Runtime _) ->
32 | Reference (ref, self#visit_type_ env ty)
33 | | None ->
34 | ice "Resolver bug"
35 |
36 | method! visit_type_ env ty =
37 | let ty = super#visit_type_ env ty in
38 | if
39 | is_immediate_expr !(ctx.scope) ctx.program
40 | (builtin_located @@ Value (Type ty))
41 | then
42 | self#with_interpreter env (builtin_located ()).span (fun inter ->
43 | inter#interpret_type ty )
44 | else self#unwrap_expr_types ty
45 |
46 | method private unwrap_expr_types =
47 | function
48 | | ExprType {value = Value (Type t); _}
49 | | ExprType
50 | {value = ResolvedReference (_, {value = Value (Type t); _}); _} ->
51 | self#unwrap_expr_types t
52 | | t ->
53 | t
54 |
55 | method! visit_Block env b =
56 | self#with_vars [] (fun _ -> super#visit_Block env b)
57 |
58 | method! visit_Let env vars =
59 | (* TODO: this won't work if `vars` will be actually a list. *)
60 | let vars' =
61 | self#visit_list
62 | (fun env (name, ex) -> (name, self#visit_expr env ex))
63 | env vars
64 | in
65 | let vars_scope =
66 | List.map vars' ~f:(fun (name, ex) ->
67 | (name, Runtime (type_of ctx.program ex)) )
68 | in
69 | ctx.scope := vars_scope :: !(ctx.scope) ;
70 | Let vars'
71 |
72 | method! visit_DestructuringLet env let_ =
73 | let expr = self#visit_expr env let_.destructuring_let_expr in
74 | match type_of ctx.program expr with
75 | | StructType id ->
76 | let struct_ = Program.get_struct ctx.program id in
77 | let vars =
78 | List.map let_.destructuring_let ~f:(fun (name, new_name) ->
79 | List.Assoc.find struct_.struct_fields
80 | ~equal:(equal_located String.equal)
81 | name
82 | |> Option.value_exn
83 | |> fun {field_type} -> (new_name, Runtime field_type) )
84 | in
85 | ctx.scope := vars :: !(ctx.scope) ;
86 | DestructuringLet {let_ with destructuring_let_expr = expr}
87 | | other_ty -> (
88 | match type_of_type ctx.program other_ty with
89 | | StructSig sign ->
90 | let struct_sign = Arena.get ctx.program.struct_signs sign in
91 | let vars =
92 | List.map let_.destructuring_let ~f:(fun (name, new_name) ->
93 | List.Assoc.find struct_sign.st_sig_fields
94 | ~equal:(equal_located String.equal)
95 | name
96 | |> Option.value_exn
97 | |> fun field_type ->
98 | (new_name, Runtime (expr_to_type ctx.program field_type)) )
99 | in
100 | ctx.scope := vars :: !(ctx.scope) ;
101 | DestructuringLet {let_ with destructuring_let_expr = expr}
102 | | _ ->
103 | ice "Type-check bug 1" )
104 |
105 | method! visit_switch env switch =
106 | let cond = self#visit_expr env switch.switch_condition in
107 | let branches =
108 | List.map switch.branches
109 | ~f:(fun {value = {branch_var; branch_ty; branch_stmt}; span} ->
110 | let stmt =
111 | self#with_vars
112 | [(branch_var, Runtime branch_ty)]
113 | (fun _ -> self#visit_stmt env branch_stmt)
114 | in
115 | {value = {branch_var; branch_ty; branch_stmt = stmt}; span} )
116 | in
117 | {switch_condition = cond; branches}
118 |
119 | method! visit_function_signature env
120 | { value =
121 | { function_attributes;
122 | function_params;
123 | function_returns;
124 | function_is_type };
125 | span } =
126 | let function_params =
127 | self#visit_list
128 | (fun env (n, e) -> (n, self#visit_type_ env e))
129 | env function_params
130 | in
131 | let vars = List.map function_params ~f:make_runtime in
132 | let function_returns =
133 | self#with_vars vars (fun _ -> self#visit_type_ env function_returns)
134 | in
135 | { value =
136 | { function_attributes;
137 | function_params;
138 | function_returns;
139 | function_is_type };
140 | span }
141 |
142 | method! visit_function_ env f =
143 | let sign =
144 | self#visit_function_signature env f.value.function_signature
145 | in
146 | ctx.functions <- ctx.functions + 1 ;
147 | let args =
148 | List.map sign.value.function_params ~f:(fun (name, ty) ->
149 | (name, Runtime ty) )
150 | in
151 | let out =
152 | self#with_vars args (fun _ ->
153 | let body = self#visit_function_impl env f.value.function_impl in
154 | {function_signature = sign; function_impl = body} )
155 | in
156 | ctx.functions <- ctx.functions - 1 ;
157 | {value = out; span = f.span}
158 |
159 | method! visit_IntfMethodCall env call =
160 | let intf_instance = self#visit_expr env call.intf_instance in
161 | let args = self#visit_list self#visit_expr env call.intf_args in
162 | match is_immediate_expr !(ctx.scope) ctx.program intf_instance with
163 | | true -> (
164 | let intf_ty =
165 | match
166 | self#with_interpreter env call.intf_loc (fun inter ->
167 | inter#interpret_expr intf_instance )
168 | with
169 | | Type t ->
170 | t
171 | | _ ->
172 | ice "Type-check bug 2"
173 | in
174 | match
175 | Program.find_impl_intf ctx.program call.intf_def intf_ty
176 | with
177 | | Some impl ->
178 | let method_ =
179 | List.find_map_exn impl.impl_methods ~f:(fun (name, impl) ->
180 | let method_name, _ = call.intf_method in
181 | if equal_string name.value method_name then Some impl
182 | else None )
183 | in
184 | FunctionCall
185 | ( {value = Value (Function method_); span = call.intf_loc},
186 | args,
187 | method_.value.function_signature.value.function_is_type )
188 | | None ->
189 | ice "Type-check bug 3" )
190 | | false ->
191 | IntfMethodCall {call with intf_instance; intf_args = args}
192 |
193 | val mutable visited_signs : (int * int) list = []
194 |
195 | method! visit_StructSig _ sign_id =
196 | match List.Assoc.find ctx.updated_items sign_id ~equal:equal_int with
197 | | Some new_id ->
198 | StructType new_id
199 | | None ->
200 | StructSig sign_id
201 |
202 | method! visit_mk_struct env mk =
203 | let mk =
204 | self#with_vars
205 | [ make_runtime
206 | ( {value = "Self"; span = mk.mk_struct_details.mk_span},
207 | StructSig mk.mk_struct_details.mk_sig ) ]
208 | (fun _ -> super#visit_mk_struct env mk)
209 | in
210 | mk
211 |
212 | method! visit_UnionSig _ sign_id =
213 | match List.Assoc.find ctx.updated_unions sign_id ~equal:equal_int with
214 | | Some new_id ->
215 | UnionType new_id
216 | | None ->
217 | UnionSig sign_id
218 |
219 | method! visit_mk_union env mk =
220 | let mk =
221 | self#with_vars
222 | [ make_runtime
223 | ( {value = "Self"; span = mk.mk_union_details.mk_span},
224 | UnionSig mk.mk_union_details.mk_sig ) ]
225 | (fun _ -> super#visit_mk_union env mk)
226 | in
227 | mk
228 |
229 | method! visit_MakeUnionVariant env (expr, uid) =
230 | let expr = self#visit_expr env expr in
231 | let new_id =
232 | match List.Assoc.find ctx.updated_items uid ~equal:equal_int with
233 | | Some new_id ->
234 | new_id
235 | | None ->
236 | uid
237 | in
238 | MakeUnionVariant (expr, new_id)
239 |
240 | method! visit_UnionVariant env (expr, uid) =
241 | let expr = self#visit_value env expr in
242 | let new_id =
243 | match List.Assoc.find ctx.updated_items uid ~equal:equal_int with
244 | | Some new_id ->
245 | new_id
246 | | None ->
247 | uid
248 | in
249 | UnionVariant (expr, new_id)
250 |
251 | method! visit_FunctionCall env (f, args, is_ty) =
252 | let f = self#visit_expr env f in
253 | let args = self#visit_list self#visit_expr env args in
254 | if
255 | is_immediate_expr !(ctx.scope) ctx.program
256 | {value = FunctionCall (f, args, is_ty); span = f.span}
257 | then
258 | Value
259 | (self#with_interpreter env f.span (fun inter ->
260 | inter#interpret_fc (f, args, is_ty) ) )
261 | else FunctionCall (f, args, is_ty)
262 |
263 | method! visit_StructSigMethodCall env call =
264 | let st_sig_instance = self#visit_expr env call.st_sig_call_instance in
265 | let args =
266 | self#visit_list self#visit_expr env call.st_sig_call_args
267 | in
268 | let method_name, m_temp = call.st_sig_call_method in
269 | let visited_method_ = self#visit_function_signature env m_temp in
270 | match is_immediate_expr !(ctx.scope) ctx.program st_sig_instance with
271 | | true ->
272 | let st_sig_ty =
273 | match
274 | self#with_interpreter env call.st_sig_call_span (fun inter ->
275 | inter#interpret_expr st_sig_instance )
276 | with
277 | | Type t ->
278 | t
279 | | _ ->
280 | ice "Type-check bug 4"
281 | in
282 | let methods = Program.methods_of ctx.program st_sig_ty in
283 | let method_ =
284 | List.find_map_exn methods ~f:(fun (name, fn) ->
285 | if equal_string name.value method_name then Some fn
286 | else None )
287 | in
288 | FunctionCall
289 | ( { value = Value (Function method_);
290 | span = call.st_sig_call_span },
291 | args,
292 | method_.value.function_signature.value.function_is_type )
293 | | false ->
294 | StructSigMethodCall
295 | { call with
296 | st_sig_call_instance = st_sig_instance;
297 | st_sig_call_args = args;
298 | st_sig_call_method = (method_name, visited_method_) }
299 |
300 | method private with_vars : 'a. _ -> (unit -> 'a) -> 'a =
301 | fun vars f ->
302 | let prev_vars = !(ctx.scope) in
303 | ctx.scope := vars :: prev_vars ;
304 | let out = f () in
305 | ctx.scope := prev_vars ;
306 | out
307 |
308 | (* FIXME: This function should create new instance of the partial_evaluator
309 | and call new_instance#visit_function_ but there is some problems with
310 | generics I can not solve yet. *)
311 | method private with_interpreter
312 | : 'a. 'env -> span -> (interpreter -> 'a) -> 'a =
313 | fun env span f ->
314 | let inter =
315 | new interpreter ctx errors span (fun ctx f ->
316 | self#with_new_ctx ctx (fun _ -> self#visit_function_ env f) )
317 | in
318 | f inter
319 |
320 | method private with_new_ctx new_ctx f =
321 | let old_ctx = ctx in
322 | ctx <- new_ctx ;
323 | let out = f () in
324 | ctx <- old_ctx ;
325 | out
326 | end
327 | end
328 |
--------------------------------------------------------------------------------
/lib/show.ml:
--------------------------------------------------------------------------------
1 | module Make =
2 | functor
3 | (Config : Config.T)
4 | ->
5 | struct
6 | open Caml.Format
7 | module Lang = Lang.Make (Config)
8 | module Interpreter = Interpreter.Make (Config)
9 |
10 | let format_to_string : 'a. 'a -> (formatter -> 'a -> unit) -> string =
11 | fun x show ->
12 | let buffer = Buffer.create 0 in
13 | let f = Format.formatter_of_buffer buffer in
14 | show f x ; pp_print_flush f () ; Buffer.contents buffer
15 |
16 | type error = [Lang.error | Interpreter.error]
17 |
18 | let list_iter ~f ~flast l =
19 | let open Base in
20 | match (List.drop_last l, List.last l) with
21 | | Some rest, Some last ->
22 | List.iter rest ~f ; flast last
23 | | _ ->
24 | ()
25 |
26 | let rec pp_expr : _ -> Lang.expr -> _ =
27 | fun f ex ->
28 | match ex.value with
29 | | Value v ->
30 | pp_value f v
31 | | FunctionCall (fname, args, is_ty) ->
32 | pp_expr f fname ;
33 | pp_print_string f (if is_ty then "[" else "(") ;
34 | list_iter args
35 | ~f:(fun e -> pp_expr f e ; pp_print_string f ", ")
36 | ~flast:(fun e -> pp_expr f e) ;
37 | pp_print_string f (if is_ty then "]" else ")")
38 | | Reference (name, _) | ResolvedReference (name, _) ->
39 | pp_print_string f name.value
40 | | StructField (s, field, _) ->
41 | pp_expr f s ;
42 | pp_print_string f "." ;
43 | pp_print_string f field.value
44 | | _ ->
45 | pp_print_string f ""
46 |
47 | and pp_value f = function
48 | | Integer i ->
49 | Z.pp_print f i
50 | | Builtin b ->
51 | pp_print_string f b
52 | | Type t ->
53 | pp_type f t
54 | | Bool true ->
55 | pp_print_string f "true"
56 | | Bool false ->
57 | pp_print_string f "false"
58 | | String s ->
59 | pp_print_string f {|"|} ;
60 | pp_print_string f s ;
61 | pp_print_string f {|"|}
62 | | _ ->
63 | pp_print_string f ""
64 |
65 | and pp_type f = function
66 | | TypeN 0 ->
67 | pp_print_string f "Type"
68 | | TypeN n ->
69 | pp_print_string f "Type" ; pp_print_int f n
70 | | IntegerType ->
71 | pp_print_string f "Integer"
72 | | BoolType ->
73 | pp_print_string f "Bool"
74 | | VoidType ->
75 | pp_print_string f "VoidType"
76 | | BuiltinType t ->
77 | pp_print_string f t
78 | | StructType s ->
79 | pp_print_string f ""
82 | | _ ->
83 | pp_print_string f ""
84 |
85 | module DiagnosticMsg = struct
86 | open Config
87 | open Located.Lexing'
88 |
89 | type t =
90 | { severity : [`Error | `Warn];
91 | diagnostic_id : int;
92 | diagnostic_msg : string;
93 | spans : (span * string) list;
94 | additional_msg : (string * string) list }
95 |
96 | open struct
97 | (*
98 | Notes about position type.
99 | pos_cnum - offset from the start of the file.
100 | pos_lnum - сurrent line.
101 | pos_bol - offset from the start of the file to the start of the line.
102 |
103 | *)
104 | let string_repeat s n =
105 | let s = Bytes.of_string s in
106 | let len = Bytes.length s in
107 | let res = Bytes.create (n * len) in
108 | for i = 0 to Int.pred n do
109 | Bytes.blit s 0 res (i * len) len
110 | done ;
111 | Bytes.to_string res
112 |
113 | let show_start_line f e =
114 | pp_print_string f
115 | (match e.severity with `Error -> "Error" | `Warn -> "Warn") ;
116 | pp_print_string f "[" ;
117 | pp_print_int f e.diagnostic_id ;
118 | pp_print_string f "]: " ;
119 | pp_print_string f e.diagnostic_msg
120 |
121 | let show_empty_line_no_newline f line_num_size spaces_count =
122 | pp_print_string f (string_repeat " " line_num_size) ;
123 | pp_print_string f "|" ;
124 | pp_print_string f (string_repeat " " spaces_count)
125 |
126 | let is_dummy (pos1, pos2) =
127 | equal_position pos1 dummy_pos || equal_position pos2 dummy_pos
128 |
129 | let range ((pos1, _) as range) =
130 | if is_dummy range then sprintf "File: \n"
131 | else
132 | let file = pos1.pos_fname in
133 | let line = pos1.pos_lnum in
134 | let char1 = pos1.pos_cnum - pos1.pos_bol in
135 | (* yes, [pos1.pos_bol] *)
136 | sprintf "File: \"%s\":%d:%d" file line char1
137 |
138 | let extract_code_line text (pos1, pos2) =
139 | let end_pos =
140 | let quit_loop = ref false in
141 | let pos_newline = ref pos1.pos_cnum in
142 | while not !quit_loop do
143 | try
144 | if
145 | Char.equal (String.get text !pos_newline) '\n'
146 | || Char.equal (String.get text !pos_newline) '\r'
147 | then quit_loop := true
148 | else pos_newline := !pos_newline + 1
149 | with _ -> quit_loop := true
150 | done ;
151 | !pos_newline
152 | in
153 | let hint_len =
154 | match Int.equal pos1.pos_lnum pos2.pos_lnum with
155 | | true ->
156 | pos2.pos_cnum - pos1.pos_cnum
157 | | false ->
158 | end_pos - pos1.pos_cnum + 3
159 | in
160 | (String.sub text pos1.pos_bol (end_pos - pos1.pos_bol), hint_len)
161 |
162 | let show_place_one_span f ((pos1, pos2) as span) span_str code
163 | line_num_size =
164 | (* Line 1 *)
165 | show_empty_line_no_newline f line_num_size 0 ;
166 | pp_print_newline f () ;
167 | (* Line 2 *)
168 | pp_print_int f pos1.pos_lnum ;
169 | pp_print_string f " | " ;
170 | let code_line, len = extract_code_line code span in
171 | let code_line =
172 | match pos1.pos_lnum == pos2.pos_lnum with
173 | | true ->
174 | code_line
175 | | false ->
176 | code_line ^ "..."
177 | in
178 | pp_print_string f code_line ;
179 | pp_print_newline f () ;
180 | let offset = pos1.pos_cnum - pos1.pos_bol in
181 | (* Line 3 *)
182 | show_empty_line_no_newline f line_num_size (offset + 1) ;
183 | pp_print_string f (string_repeat "^" len) ;
184 | pp_print_string f " " ;
185 | pp_print_string f span_str ;
186 | pp_print_newline f () ;
187 | ()
188 |
189 | (* This functions works correctly only with numbers bigger than 0 *)
190 | let int_digits_count i =
191 | let rec int_digits_count_inner c = function
192 | | 0 ->
193 | c
194 | | n ->
195 | int_digits_count_inner (c + 1) (n / 10)
196 | in
197 | int_digits_count_inner 0 i
198 | end
199 |
200 | let show f e code =
201 | let open Base in
202 | let ((pos1, _) as span1), _ =
203 | List.hd_exn e.spans |> fun (s, e) -> (span_to_concrete s, e)
204 | in
205 | show_start_line f e ;
206 | pp_print_newline f () ;
207 | pp_print_string f (range span1) ;
208 | pp_print_newline f () ;
209 | if equal_position pos1 dummy_pos then ()
210 | else
211 | match e.spans with
212 | | (s, sm) :: [] ->
213 | let line_num_size = int_digits_count pos1.pos_lnum + 1 in
214 | show_place_one_span f (span_to_concrete s) sm code line_num_size
215 | | _ ->
216 | Errors.ice "There are should be only one span in the list"
217 | end
218 |
219 | let show_error : string -> error -> string =
220 | fun code e ->
221 | format_to_string ()
222 | @@ fun f _ ->
223 | match e with
224 | | `DuplicateField (field, _) ->
225 | DiagnosticMsg.show f
226 | { severity = `Error;
227 | diagnostic_id = 1;
228 | diagnostic_msg = "Duplicate struct field " ^ field.value;
229 | spans = [(field.span, "Duplicated")];
230 | additional_msg = [] }
231 | code
232 | | `DuplicateVariant (ty, span) ->
233 | DiagnosticMsg.show f
234 | { severity = `Error;
235 | diagnostic_id = 1;
236 | diagnostic_msg =
237 | "Duplicate variant with type " ^ format_to_string ty pp_type;
238 | spans = [(span, "Duplicated variant in this union")];
239 | additional_msg = [] }
240 | code
241 | | `UnresolvedIdentifier id ->
242 | DiagnosticMsg.show f
243 | { severity = `Error;
244 | diagnostic_id = 1;
245 | diagnostic_msg = "Unresolved identifier " ^ id.value;
246 | spans = [(id.span, "Cannot resolve this identifier")];
247 | additional_msg = [] }
248 | code
249 | | `MethodNotFound (e, m) ->
250 | DiagnosticMsg.show f
251 | { severity = `Error;
252 | diagnostic_id = 1;
253 | diagnostic_msg =
254 | "Method " ^ m.value ^ " not found in "
255 | ^ format_to_string e pp_expr;
256 | spans = [(m.span, "Method not found")];
257 | additional_msg = [] }
258 | code
259 | | `TypeError (expected, actual, span) ->
260 | let expected = format_to_string expected pp_type in
261 | let actual = format_to_string actual pp_type in
262 | DiagnosticMsg.show f
263 | { severity = `Error;
264 | diagnostic_id = 1;
265 | diagnostic_msg =
266 | "Expected type `" ^ expected ^ "` but found `" ^ actual ^ "`";
267 | spans = [(span, "This has type `" ^ actual ^ "`")];
268 | additional_msg = [] }
269 | code
270 | | `ExpectedFunction (got, span) ->
271 | DiagnosticMsg.show f
272 | { severity = `Error;
273 | diagnostic_id = 1;
274 | diagnostic_msg =
275 | "Expected function but got value with `"
276 | ^ format_to_string got pp_type
277 | ^ "` type.";
278 | spans = [(span, "This cannot be called")];
279 | additional_msg = [] }
280 | code
281 | | `OnlyFunctionIsAllowed span ->
282 | DiagnosticMsg.show f
283 | { severity = `Error;
284 | diagnostic_id = 1;
285 | diagnostic_msg = "Only function is allowed ";
286 | spans = [(span, "Only function is allowed here")];
287 | additional_msg = [] }
288 | code
289 | | `ArgumentNumberMismatch (expected, actual, span) ->
290 | DiagnosticMsg.show f
291 | { severity = `Error;
292 | diagnostic_id = 1;
293 | diagnostic_msg =
294 | "Expected " ^ string_of_int expected ^ " arguments but found "
295 | ^ string_of_int actual ^ ".";
296 | spans = [(span, "When calling this function")];
297 | additional_msg = [] }
298 | code
299 | | `UninterpretableStatement (_, span) ->
300 | DiagnosticMsg.show f
301 | { severity = `Error;
302 | diagnostic_id = 1;
303 | diagnostic_msg = "Uninterpretable statement.";
304 | spans = [(span, "This statement cannot be interpreted")];
305 | additional_msg = [] }
306 | code
307 | | `FieldNotFoundF field | `FieldNotFound (_, field) ->
308 | DiagnosticMsg.show f
309 | { severity = `Error;
310 | diagnostic_id = 1;
311 | diagnostic_msg = "Field `" ^ field.value ^ "` not found.";
312 | spans = [(field.span, "This field not found")];
313 | additional_msg = [] }
314 | code
315 | | `MissingField (_, field, span) ->
316 | DiagnosticMsg.show f
317 | { severity = `Error;
318 | diagnostic_id = 1;
319 | diagnostic_msg =
320 | "Field `" ^ field.value
321 | ^ "` missing in destructuring statement.";
322 | spans = [(span, "In this binding")];
323 | additional_msg = [] }
324 | code
325 | | `CannotHaveMethods (expr, ty) ->
326 | DiagnosticMsg.show f
327 | { severity = `Error;
328 | diagnostic_id = 1;
329 | diagnostic_msg =
330 | "Type `"
331 | ^ format_to_string ty pp_type
332 | ^ "` cannot have methods.";
333 | spans = [(expr.span, "This cannot have methods")];
334 | additional_msg = [] }
335 | code
336 | | `IsNotStruct expr ->
337 | DiagnosticMsg.show f
338 | { severity = `Error;
339 | diagnostic_id = 1;
340 | diagnostic_msg =
341 | "Expression is not struct type, so it cannot be used in such \
342 | context.";
343 | spans = [(expr.span, "This is not struct type")];
344 | additional_msg = [] }
345 | code
346 | | `IsNotUnion expr ->
347 | DiagnosticMsg.show f
348 | { severity = `Error;
349 | diagnostic_id = 1;
350 | diagnostic_msg =
351 | "Expression is not union type, so it cannot be used in such \
352 | context.";
353 | spans = [(expr.span, "This is not union type")];
354 | additional_msg = [] }
355 | code
356 | | `CaseNotFound span ->
357 | DiagnosticMsg.show f
358 | { severity = `Error;
359 | diagnostic_id = 1;
360 | diagnostic_msg = "Case type not found in union.";
361 | spans =
362 | [ ( span,
363 | "Type of this variable is not found in the condition union"
364 | ) ];
365 | additional_msg = [] }
366 | code
367 | | `ExpectedTypeFunction (is_type_fn, span) ->
368 | let diagnostic_msg =
369 | if is_type_fn then
370 | "Function should be called using `[]` brackets but called with \
371 | `()` parens."
372 | else
373 | "Function should be called using `()` brackets but called with \
374 | `[]` parens."
375 | in
376 | DiagnosticMsg.show f
377 | { severity = `Error;
378 | diagnostic_id = 1;
379 | diagnostic_msg;
380 | spans = [(span, "When calling this function")];
381 | additional_msg = [] }
382 | code
383 | end
384 |
--------------------------------------------------------------------------------
/lib/std/std.tact:
--------------------------------------------------------------------------------
1 | struct Cell {
2 | val c: builtin_Cell
3 | }
4 |
5 | // Do not change place of builder struct - for internal reasons
6 | // it should be second struct in the file.
7 | struct Builder {
8 | val inner: builtin_Builder
9 |
10 | fn new() -> Self {
11 | Self { inner: builtin_begin_cell() }
12 | }
13 | fn build(self: Self) -> Cell {
14 | Cell { c: builtin_end_cell(self.inner) }
15 | }
16 | fn serialize_int(self: Self, int: Integer, bits: Integer) -> Self {
17 | Self { inner: builtin_store_int(self.inner, int, bits) }
18 | }
19 | fn serialize_uint(self: Self, uint: Integer, bits: Integer) -> Self {
20 | Self { inner: builtin_store_uint(self.inner, uint, bits) }
21 | }
22 | fn serialize_coins(self: Self, c: Integer) -> Self {
23 | Self { inner: builtin_store_grams(self.inner, c) }
24 | }
25 | fn serialize_ref(self: Self, cell: Cell) -> Self {
26 | Self { inner: builtin_store_ref(self.inner, cell.c) }
27 | }
28 | fn serialize_maybe_ref(self: Self, maybe_cell: Cell) -> Self {
29 | Self { inner: builtin_store_maybe_ref(self.inner, maybe_cell.c) }
30 | }
31 | fn bits(self: Self) -> Integer {
32 | builtin_builder_bits(self.inner)
33 | }
34 | fn refs(self: Self) -> Integer {
35 | builtin_builder_refs(self.inner)
36 | }
37 | fn depth(self: Self) -> Integer {
38 | builtin_builder_depth(self.inner)
39 | }
40 | }
41 |
42 | struct Slice {
43 | val s: builtin_Slice
44 |
45 | fn parse(cell: Cell) -> Self {
46 | Self { s: builtin_begin_parse(cell.c) }
47 | }
48 |
49 | fn load_int(self: Self, bits: Integer) -> LoadResult[Integer] {
50 | let output = builtin_load_int(self.s, bits);
51 | let slice = Self { s: output.value1 };
52 | let int = output.value2;
53 | LoadResult[Integer] { slice: believe_me(slice), value: int }
54 | }
55 |
56 | fn load_uint(self: Self, bits: Integer) -> LoadResult[Integer] {
57 | let output = builtin_load_uint(self.s, bits);
58 | let slice = Self { s: output.value1 };
59 | let int = output.value2;
60 | LoadResult[Integer] { slice: believe_me(slice), value: int }
61 | }
62 |
63 | fn load_coins(self: Self) -> LoadResult[Integer] {
64 | let output = builtin_load_grams(self.s);
65 | let slice = Self { s: output.value1 };
66 | let coins = output.value2 ;
67 | LoadResult[Integer] { slice: believe_me(slice), value: coins }
68 | }
69 |
70 | fn load_ref(self: Self) -> LoadResult[Cell] {
71 | let output = builtin_load_ref(self.s);
72 | let slice = Self { s: output.value1 };
73 | let ref = Cell { c: output.value2 };
74 | LoadResult[Cell] { slice: believe_me(slice), value: ref }
75 | }
76 |
77 | fn load_bits(self: Self, bits: Integer) -> LoadResult[Self] {
78 | let output = builtin_load_bits(self.s, bits);
79 | let slice = Self { s: output.value1 };
80 | let slice2 = Self { s: output.value2 };
81 | LoadResult[Self] { slice: believe_me(slice), value: believe_me(slice2) }
82 | }
83 |
84 | /* Developer notes: if you add `LoadResult[...]` type, don't forget to
85 | increment Slice id in the `builtins.ml` */
86 |
87 | fn refs_count(self: Self) -> Integer {
88 | builtin_slice_refs(self.s)
89 | }
90 | fn bits(self: Self) -> Integer {
91 | builtin_slice_bits(self.s)
92 | }
93 |
94 | impl Serialize {
95 | fn serialize(self: Self, b: Builder) -> Builder {
96 | Builder { inner: builtin_store_slice(b.inner, self.s) }
97 | }
98 | }
99 | }
100 |
101 | struct RefCell {
102 | val inner: Cell
103 |
104 | impl Serialize {
105 | fn serialize(self: Self, b: Builder) -> Builder {
106 | b.serialize_ref(self.inner)
107 | }
108 | }
109 | impl Deserialize {
110 | fn deserialize(s: Slice) -> LoadResult[Self] {
111 | let {slice, value} = s.load_ref();
112 | LoadResult[Self].new(Self { inner: value }, slice)
113 | }
114 | }
115 | }
116 |
117 | struct TypedSerializeCell[X: Serialize] {
118 | val value: X
119 |
120 | impl Serialize {
121 | fn serialize(self: Self, b: Builder) -> Builder {
122 | let cell = self.value.serialize(Builder.new()).build();
123 | b.serialize_ref(cell)
124 | }
125 | }
126 | }
127 |
128 | struct TypedDeserializeCell[X: Deserialize] {
129 | val value: X
130 |
131 | impl Deserialize {
132 | fn deserialize(s: Slice) -> LoadResult[Self] {
133 | let {slice, value} = s.load_ref();
134 | let {slice as _, value} = X.deserialize(Slice.parse(value));
135 | LoadResult[Self].new(Self { value: believe_me(value) }, slice)
136 | }
137 | }
138 | }
139 |
140 | struct SliceBits[N: Integer] {
141 | val inner: Slice
142 |
143 | @derive impl Serialize {}
144 |
145 | impl Deserialize {
146 | fn deserialize(s: Slice) -> LoadResult[Self] {
147 | let {value, slice} = s.load_bits(N);
148 | LoadResult[Self].new(Self { inner: value }, slice)
149 | }
150 | }
151 | }
152 |
153 | fn thrown(n: Integer) {
154 | builtin_throw(n);
155 | }
156 |
157 | struct Coins {
158 | val value: Integer
159 |
160 | fn new(c: Integer) -> Self {
161 | Self { value: c }
162 | }
163 |
164 | impl Serialize {
165 | fn serialize(self: Self, builder: Builder) -> Builder {
166 | builder.serialize_coins(self.value)
167 | }
168 | }
169 |
170 | impl Deserialize {
171 | fn deserialize(s: Slice) -> LoadResult[Self] {
172 | let {slice, value} = s.load_coins();
173 | LoadResult[Self].new(Self { value: value }, slice)
174 | }
175 | }
176 | }
177 |
178 | struct Int[bits: Integer] {
179 | val value: Integer
180 |
181 | fn new(i: Integer) -> Self {
182 | Self { value: i }
183 | }
184 |
185 | fn add(self: Self, other: Self) { Self { value: self.value + other.value } }
186 | fn sub(self: Self, other: Self) { Self { value: self.value - other.value } }
187 | fn mul(self: Self, other: Self) { Self { value: self.value * other.value } }
188 | fn div(self: Self, other: Self) { Self { value: self.value / other.value } }
189 | fn bit_and(self: Self, other: Self) { Self { value: self.value & other.value } }
190 | fn bit_or(self: Self, other: Self) { Self { value: self.value | other.value } }
191 | fn eq(self: Self, other: Self) { self.value == other.value }
192 | fn neq(self: Self, other: Self) { self.value != other.value }
193 | fn leq(self: Self, other: Self) { self.value <= other.value }
194 | fn lt(self: Self, other: Self) { self.value < other.value }
195 | fn lt(self: Self, other: Self) { self.value < other.value }
196 | fn geq(self: Self, other: Self) { self.value >= other.value }
197 | fn gt(self: Self, other: Self) { self.value > other.value }
198 |
199 | impl Serialize {
200 | fn serialize(self: Self, builder: Builder) -> Builder {
201 | builder.serialize_int(self.value, bits)
202 | }
203 | }
204 |
205 | impl Deserialize {
206 | fn deserialize(s: Slice) -> LoadResult[Self] {
207 | let res = s.load_int(bits);
208 | let {slice, value} = res;
209 |
210 | LoadResult[Self] {
211 | slice: slice,
212 | value: Self { value: value }
213 | }
214 | }
215 | }
216 |
217 | impl From[Integer] {
218 | fn from(i: Integer) -> Self {
219 | Self { value: i }
220 | }
221 | }
222 | }
223 |
224 | struct Uint[bits: Integer] {
225 | val value: Integer
226 |
227 | fn new(i: Integer) -> Self {
228 | Self { value: i }
229 | }
230 |
231 | fn add(self: Self, other: Self) { Self { value: self.value + other.value } }
232 | fn sub(self: Self, other: Self) { Self { value: self.value - other.value } }
233 | fn mul(self: Self, other: Self) { Self { value: self.value * other.value } }
234 | fn div(self: Self, other: Self) { Self { value: self.value / other.value } }
235 | fn bit_and(self: Self, other: Self) { Self { value: self.value & other.value } }
236 | fn bit_or(self: Self, other: Self) { Self { value: self.value | other.value } }
237 | fn eq(self: Self, other: Self) { self.value == other.value }
238 | fn neq(self: Self, other: Self) { self.value != other.value }
239 | fn leq(self: Self, other: Self) { self.value <= other.value }
240 | fn lt(self: Self, other: Self) { self.value < other.value }
241 | fn lt(self: Self, other: Self) { self.value < other.value }
242 | fn geq(self: Self, other: Self) { self.value >= other.value }
243 | fn gt(self: Self, other: Self) { self.value > other.value }
244 |
245 | impl Serialize {
246 | fn serialize(self: Self, builder: Builder) -> Builder {
247 | builder.serialize_uint(self.value, bits)
248 | }
249 | }
250 |
251 | impl Deserialize {
252 | fn deserialize(s: Slice) -> LoadResult[Self] {
253 | let res = s.load_uint(bits);
254 |
255 | LoadResult[Self] {
256 | slice: res.slice,
257 | value: Self { value: res.value }
258 | }
259 | }
260 | }
261 |
262 | impl From[Integer] {
263 | fn from(i: Integer) -> Self {
264 | Self { value: i }
265 | }
266 | }
267 | }
268 |
269 | struct AddrNone {
270 | impl Serialize {
271 | fn serialize(self: Self, b: Builder) -> Builder {
272 | return b;
273 | }
274 | }
275 |
276 | impl Deserialize {
277 | fn deserialize(s: Slice) -> LoadResult[Self] {
278 | return LoadResult[Self].new(s, Self{});
279 | }
280 | }
281 | }
282 |
283 | // Interesting situation with this declaration: `bits` field should have count of bits
284 | // deriving from the `len` field which requires more powerful dependent types than we have for now.
285 | // Do we want to make such declarations possible?
286 | struct AddrExtern {
287 | val len: Int9
288 | val bits: Integer
289 |
290 | impl Serialize {
291 | fn serialize(self: Self, b: Builder) -> Builder {
292 | let b = self.len.serialize(b);
293 | let b = b.serialize_int(self.bits, self.len.value);
294 | return b;
295 | }
296 | }
297 |
298 | impl Deserialize {
299 | fn deserialize(slice: Slice) -> LoadResult[Self] {
300 | let {value as len, slice} = Int9.deserialize(slice);
301 | let {value as bits, slice} = slice.load_int(len.value);
302 |
303 | LoadResult[Self] {
304 | slice: slice,
305 | value: Self {
306 | len: len,
307 | bits: bits,
308 | }
309 | }
310 | }
311 | }
312 | }
313 |
314 | union MsgAddressExt {
315 | @discriminator(0, 2) // 0b00
316 | case AddrNone
317 | @discriminator(1, 2) // 0b01
318 | case AddrExtern
319 |
320 | @derive
321 | impl Serialize {}
322 |
323 | @derive
324 | impl Deserialize {}
325 | }
326 |
327 | struct AddressStd {
328 | val workchain_id: Int8
329 | val address: Int256
330 |
331 | fn new(workchain_id: Int8, address: Int256) -> Self {
332 | Self {
333 | workchain_id: workchain_id,
334 | address: address,
335 | }
336 | }
337 |
338 | impl Serialize {
339 | fn serialize(self: Self, b: Builder) -> Builder {
340 | let b = b.serialize_int(0, 0); // AnyCast
341 | serializer[Self](self, b)
342 | }
343 | }
344 |
345 | impl Deserialize {
346 | fn deserialize(s: Slice) -> LoadResult[Self] {
347 | let res_anycast = s.load_int(1);
348 | if (res_anycast.value == 0) {
349 | return deserializer[Self](s);
350 | } else {
351 | thrown(0); // unreachable
352 | }
353 | }
354 | }
355 | }
356 |
357 | struct AddressVar {
358 | val len: Int9
359 | val workchain_id: Int32
360 | val address: Integer
361 |
362 | impl Serialize {
363 | fn serialize(self: Self, b: Builder) -> Builder {
364 | let b = b.serialize_int(0, 0); // AnyCast
365 | let b = serializer[Self](self, b);
366 | return b;
367 | }
368 | }
369 |
370 | impl Deserialize {
371 | fn deserialize(s: Slice) -> LoadResult[Self] {
372 | let {value as anycast, slice} = s.load_int(1);
373 | if (anycast == 0) {
374 | let {value as len, slice} = Int9.deserialize(slice);
375 | let {value as workchain_id, slice} = Int32.deserialize(slice);
376 | let {value as address, slice} = slice.load_int(len.value);
377 | return LoadResult[Self]
378 | .new(slice, Self {
379 | len: len,
380 | workchain_id: workchain_id,
381 | address: address,
382 | });
383 | } else {
384 | thrown(0); // unreachable
385 | }
386 | }
387 | }
388 | }
389 |
390 | union MsgAddressInt {
391 | @discriminator(2, 2) // 0b10
392 | case AddressStd
393 | @discriminator(3, 2) // 0b11
394 | case AddressVar
395 |
396 | @derive
397 | impl Serialize {}
398 |
399 | @derive
400 | impl Deserialize {}
401 | }
402 |
403 | union MsgAddress {
404 | case AddrNone
405 | case AddrExtern
406 | case AddressStd
407 | case AddressVar
408 |
409 | @derive
410 | impl Serialize {}
411 |
412 | @derive
413 | impl Deserialize {}
414 | }
415 |
416 | struct ExtOutMsgInfoRelaxed {
417 | val src: MsgAddress
418 | val dest: MsgAddressExt
419 | val created_lt: Uint64
420 | val created_at: Uint32
421 |
422 | @derive
423 | impl Serialize {}
424 | }
425 |
426 | struct Timestamps {
427 | val created_lt: Uint64
428 | val created_at: Uint32
429 |
430 | fn zeros() -> Self {
431 | Self {
432 | created_lt: 0,
433 | created_at: 0,
434 | }
435 | }
436 |
437 | @derive
438 | impl Serialize {}
439 |
440 | @derive
441 | impl Deserialize {}
442 | }
443 |
444 | struct IntMsgInfoFlags {
445 | val ihr_disabled: Uint1
446 | val bounce: Uint1
447 | val bounced: Uint1
448 |
449 | fn new(ihr_disabled: Bool, bounce: Bool) -> Self {
450 | fn bool_to_int(x: Bool) -> Uint1 {
451 | if (x) {
452 | return 1;
453 | } else {
454 | return 0;
455 | }
456 | }
457 | Self {
458 | ihr_disabled: bool_to_int(ihr_disabled),
459 | bounce: bool_to_int(bounce),
460 | bounced: 0, // will be rewrited by the validator
461 | }
462 | }
463 |
464 | @derive
465 | impl Serialize {}
466 |
467 | @derive
468 | impl Deserialize {}
469 | }
470 |
471 | struct IntMsgInfoAddresses {
472 | val src: MsgAddressInt
473 | val dst: MsgAddressInt
474 |
475 | @derive
476 | impl Serialize {}
477 |
478 | @derive
479 | impl Deserialize {}
480 | }
481 |
482 | struct IntMsgInfoCoins {
483 | val amount: Coins
484 | val _extra_currencies: Uint1 // we ignore extra_currencies for now
485 | val ihr_fee: Coins
486 | val fwd_fee: Coins
487 |
488 | fn new(amount: Coins, ihr_fee: Coins, fwd_fee: Coins) -> Self {
489 | Self {
490 | amount: amount,
491 | _extra_currencies: 0,
492 | ihr_fee: ihr_fee,
493 | fwd_fee: fwd_fee,
494 | }
495 | }
496 |
497 | @derive
498 | impl Serialize {}
499 |
500 | @derive
501 | impl Deserialize {}
502 | }
503 |
504 | struct IntMsgInfo {
505 | val flags: IntMsgInfoFlags
506 | val addresses: IntMsgInfoAddresses
507 | val coins: IntMsgInfoCoins
508 | val timestamps: Timestamps
509 |
510 | fn new(
511 | flags: IntMsgInfoFlags,
512 | dst: MsgAddressInt,
513 | coins: IntMsgInfoCoins,
514 | ) -> Self {
515 | Self {
516 | flags: flags,
517 | addresses: IntMsgInfoAddresses {
518 | src: AddressStd.new(0, 0), // it will be replaced by smartcontract address by TVM
519 | dst: dst,
520 | },
521 | coins: coins,
522 | timestamps: Timestamps.zeros(), // it will be replaced by current timestamps by TVM
523 | }
524 | }
525 |
526 | @derive
527 | impl Serialize {}
528 |
529 | @derive
530 | impl Deserialize {}
531 | }
532 |
533 | struct ExtInMsgInfo {
534 | val src: MsgAddressExt
535 | val dest: MsgAddressInt
536 | val import_fee: Coins
537 |
538 | @derive
539 | impl Deserialize {}
540 | }
541 |
542 | union CommonMsgInfo {
543 | case IntMsgInfo
544 | @discriminator(2, 2) // 0b10
545 | case ExtInMsgInfo
546 |
547 | @derive
548 | impl Serialize {}
549 |
550 | @derive
551 | impl Deserialize {}
552 | }
553 |
554 | union CommonMsgInfoRelaxed {
555 | case ExtOutMsgInfoRelaxed
556 | case IntMsgInfo
557 |
558 | impl Serialize {
559 | fn serialize(self: Self, b: Builder) -> Builder {
560 | switch(self) {
561 | case IntMsgInfo info => {
562 | let b = b.serialize_int(0, 1);
563 | return info.serialize(b);
564 | }
565 | case ExtOutMsgInfoRelaxed info => {
566 | let b = b.serialize_int(3, 2); // 0b11
567 | return info.serialize(b);
568 | }
569 | }
570 | }
571 | }
572 | }
573 |
574 | struct MessageRelaxed[X: Serialize] {
575 | val info: CommonMsgInfoRelaxed
576 | val body: X
577 |
578 | impl Serialize {
579 | fn serialize(self: Self, b: Builder) -> Builder {
580 | let b = self.info.serialize(b);
581 | let b = b.serialize_int(0, 1); // init
582 | let b = b.serialize_int(0, 1); // body discriminant
583 | let b = self.body.serialize(b);
584 | return b;
585 | }
586 | }
587 | }
588 |
589 | struct Message[X: Deserialize] {
590 | val info: CommonMsgInfo
591 | val body: X
592 |
593 | impl Deserialize {
594 | fn deserialize(s: Slice) -> LoadResult[Self] {
595 | let {slice, value as info} = CommonMsgInfo.deserialize(s);
596 | let {slice, value as init} = slice.load_int(1);
597 |
598 | if (init == 0) {
599 | let {slice, value as discr} = slice.load_int(1);
600 | if (discr == 0) {
601 | let {slice, value as body} = X.deserialize(slice);
602 | // FIXME: weird bug
603 | let mes = Self { info: info, body: believe_me(body) };
604 | return LoadResult[Self].new(mes, slice);
605 | } else {
606 | /* TODO: cells */
607 | thrown(0);
608 | }
609 | } else {
610 | thrown(0);
611 | }
612 | }
613 | }
614 | }
615 |
616 | struct SendRawMsgFlags {
617 | val value: Int8
618 |
619 | fn default() -> Self {
620 | Self { value: 0 }
621 | }
622 |
623 | fn carry_remaining_balance(self: Self) -> Self {
624 | Self { value: self.value.value + 128 }
625 | }
626 |
627 | fn carry_remaining_input(self: Self) -> Self {
628 | Self { value: self.value.value + 64 }
629 | }
630 |
631 | @derive
632 | impl Deserialize {}
633 |
634 | @derive
635 | impl Serialize {}
636 | }
637 |
638 | fn send_raw_msg(msg: Cell, flags: SendRawMsgFlags) -> VoidType {
639 | builtin_send_raw_message(msg.c, flags.value.value);
640 | }
641 |
642 | fn send_internal[X: Serialize](header: IntMsgInfo, body: X, flags: SendRawMsgFlags) -> VoidType {
643 | let info: CommonMsgInfoRelaxed = header;
644 | let msg = MessageRelaxed[X] { info: info, body: body };
645 | let ce = msg.serialize(Builder.new()).build();
646 | send_raw_msg(ce, flags);
647 | }
648 |
649 | fn send_external[X: Serialize](header: ExtOutMsgInfoRelaxed, body: X, flags: SendRawMsgFlags) -> VoidType {
650 | let info: CommonMsgInfoRelaxed = header;
651 | let msg = MessageRelaxed[X] { info: info, body: body };
652 | let ce = msg.serialize(Builder.new()).build();
653 | send_raw_msg(ce, flags);
654 | }
655 |
656 | fn hash_of_slice(s: Slice) -> Uint256 {
657 | return Uint256.new(builtin_slice_hash(s.s));
658 | }
659 |
660 | fn is_signature_valid(hash: Uint256, sign: SliceBits[512], pubkey: Uint256) -> Bool {
661 | return builtin_check_signature(hash.value, sign.inner.s, pubkey.value);
662 | }
663 |
664 | struct Signature {
665 | val _sig: SliceBits[512]
666 | val _rest: Slice
667 |
668 | fn is_valid(self: Self, public_key: Uint256) -> Bool {
669 | return is_signature_valid(hash_of_slice(self._rest), self._sig, public_key);
670 | }
671 |
672 | impl Deserialize {
673 | fn deserialize(s: Slice) -> LoadResult[Self] {
674 | let {value as sig, slice} = SliceBits[512].deserialize(s);
675 | LoadResult[Self].new(Self{_sig: sig, _rest: slice}, slice)
676 | }
677 | }
678 | }
679 |
680 | /* Deserialize rest of the slice into this struct */
681 | struct RestSlice {
682 | val inner: Slice
683 |
684 | impl Deserialize {
685 | fn deserialize(s: Slice) -> LoadResult[Self] {
686 | let empty_slice = builtin_slice_last(s.s, 0);
687 | LoadResult[Self].new(Self{inner: s}, empty_slice)
688 | }
689 | }
690 | }
691 |
692 | struct SignedBody[X: Deserialize] {
693 | val _sign: Signature
694 | val _rest: X
695 |
696 | fn verify_body(self: Self, pubkey: Uint256) -> X {
697 | if (self._sign.is_valid(pubkey)) {
698 | return self._rest;
699 | } else {
700 | thrown(0);
701 | // This will never be called but without this return, FunC does not compile
702 | // this code.
703 | return self._rest;
704 | }
705 | }
706 |
707 | impl Deserialize {
708 | fn deserialize(slice: Slice) -> LoadResult[Self] {
709 | let {value as sign, slice} = Signature.deserialize(slice);
710 | let {value as rest, slice} = X.deserialize(slice);
711 | LoadResult[Self].new(
712 | Self { _sign: sign, _rest: believe_me(rest) },
713 | slice
714 | )
715 | }
716 | }
717 | }
718 |
719 | struct Globals {
720 | fn load_state() -> Cell {
721 | Cell { c: builtin_get_data() }
722 | }
723 | fn save_state(state: Cell) {
724 | builtin_set_data(state.c);
725 | }
726 | fn get_now() -> Uint[32] {
727 | builtin_now()
728 | }
729 | fn get_my_address() -> AddressStd {
730 | AddressStd.deserialize(Slice { s: builtin_my_address() }).value
731 | }
732 | fn get_balance() -> Coins {
733 | struct Balance {
734 | val tons: Coins
735 | val extra_currencies: Cell
736 | }
737 | let balance: Balance = believe_me(builtin_get_balance());
738 | return balance.tons;
739 | }
740 | fn get_logical_time() -> Int[64] {
741 | builtin_cur_lt()
742 | }
743 | fn get_block_logical_time() -> Int[64] {
744 | builtin_block_lt()
745 | }
746 | }
747 |
748 | struct RemainingBalance{}
749 | struct RemainingInput{}
750 | union Money {
751 | case Coins
752 | case RemainingBalance
753 | case RemainingInput
754 | }
755 |
756 | struct RequestBuilder[X: Serialize] {
757 | val msg_flags: IntMsgInfoFlags
758 | val send_flags: SendRawMsgFlags
759 | val coins: IntMsgInfoCoins
760 | val is_body_setup: Bool // TODO: make `Option[T]` type.
761 | val body: X
762 |
763 | fn new() -> Self {
764 | Self {
765 | msg_flags: IntMsgInfoFlags.new(false, false),
766 | send_flags: SendRawMsgFlags.default(),
767 | coins: IntMsgInfoCoins.new(Coins.new(0), Coins.new(0), Coins.new(0)),
768 | is_body_setup: false,
769 | body: believe_me(0),
770 | }
771 | }
772 |
773 | fn can_be_bounced(self: Self) -> Self {
774 | Self {
775 | msg_flags: IntMsgInfoFlags { ihr_disabled: self.msg_flags.ihr_disabled, bounce: 1, bounced: 0 },
776 | send_flags: self.send_flags,
777 | body: self.body,
778 | is_body_setup: self.is_body_setup,
779 | coins: self.coins,
780 | }
781 | }
782 | fn ihr_disabled(self: Self) -> Self {
783 | Self {
784 | msg_flags: IntMsgInfoFlags { ihr_disabled: 1, bounce: self.msg_flags.bounce, bounced: 0 },
785 | send_flags: self.send_flags,
786 | body: self.body,
787 | is_body_setup: self.is_body_setup,
788 | coins: self.coins,
789 | }
790 | }
791 | fn money(self: Self, money: Money) -> Self {
792 | switch (money) {
793 | case Coins coins => {
794 | return Self {
795 | msg_flags: self.msg_flags,
796 | send_flags: self.send_flags,
797 | body: self.body,
798 | is_body_setup: self.is_body_setup,
799 | coins: IntMsgInfoCoins.new(coins, self.coins.ihr_fee, self.coins.fwd_fee),
800 | };
801 | }
802 | case RemainingBalance _ => {
803 | return Self {
804 | msg_flags: self.msg_flags,
805 | send_flags: self.send_flags.carry_remaining_balance(),
806 | body: self.body,
807 | is_body_setup: self.is_body_setup,
808 | coins: self.coins,
809 | };
810 | }
811 | case RemainingInput _ => {
812 | return Self {
813 | msg_flags: self.msg_flags,
814 | send_flags: self.send_flags.carry_remaining_input(),
815 | body: self.body,
816 | is_body_setup: self.is_body_setup,
817 | coins: self.coins,
818 | };
819 | }
820 | }
821 | }
822 | fn body(self: Self, body: X) -> Self {
823 | Self {
824 | msg_flags: self.msg_flags,
825 | send_flags: self.send_flags,
826 | body: body,
827 | is_body_setup: true,
828 | coins: self.coins,
829 | }
830 | }
831 | fn send_to(self: Self, dst: MsgAddressInt) {
832 | if (self.is_body_setup) {
833 | // TODO: I don't know why MessageRelaxed[X] type does not work here.
834 | let info = IntMsgInfo.new(self.msg_flags, dst, self.coins);
835 | let b = CommonMsgInfo.serialize(info, Builder.new());
836 | let b = b.serialize_int(0, 1); // init
837 | let b = b.serialize_int(0, 1); // body discriminant
838 | let b = self.body.serialize(b);
839 | send_raw_msg(b.build(), self.send_flags);
840 | } else {
841 | thrown(87);
842 | }
843 | }
844 | }
845 |
--------------------------------------------------------------------------------
/lib/syntax.ml:
--------------------------------------------------------------------------------
1 | open Sexplib.Std
2 |
3 | module Make =
4 | functor
5 | (Config : Config.T)
6 | ->
7 | struct
8 | include Config
9 |
10 | class ['s] base_visitor =
11 | object (_ : 's)
12 | inherit ['s] VisitorsRuntime.map
13 |
14 | inherit ['s] Zint.map
15 |
16 | method visit_located
17 | : 'a 'b. ('env -> 'a -> 'b) -> 'env -> 'a located -> 'b located =
18 | fun f env l -> {value = f env l.value; span = l.span}
19 |
20 | method visit_span _ span = span
21 | end
22 |
23 | type ident = Ident of string
24 |
25 | and struct_definition =
26 | { struct_attributes : attribute list; [@sexp.list]
27 | fields : struct_field located list; [@sexp.list]
28 | struct_bindings : binding located list; [@sexp.list]
29 | impls : impl list; [@sexp.list]
30 | struct_span : (span[@sexp.opaque]) }
31 |
32 | and impl =
33 | { impl_attributes : attribute list; [@sexp.list]
34 | interface : expr located;
35 | methods : binding located list }
36 |
37 | and interface_definition =
38 | { interface_attributes : attribute list; [@sexp.list]
39 | interface_members : binding located list [@sexp.list] }
40 |
41 | and function_call =
42 | { fn : expr located;
43 | arguments : expr located list; [@sexp.list]
44 | is_type_func_call : bool [@sexp.bool] }
45 |
46 | and method_call =
47 | { receiver : expr located;
48 | receiver_fn : ident located;
49 | receiver_arguments : expr located list }
50 |
51 | (* TODO: union impls *)
52 | and union_definition =
53 | { union_attributes : attribute list; [@sexp.list]
54 | union_members : (expr located * attribute list) list; [@sexp.list]
55 | union_bindings : binding located list; [@sexp.list]
56 | union_impls : impl list; [@sexp.list]
57 | union_span : (span[@sexp.opaque]) }
58 |
59 | and attribute =
60 | { attribute_ident : ident located;
61 | attribute_exprs : expr located list [@sexp.list] }
62 |
63 | and expr =
64 | | Struct of struct_definition
65 | | StructConstructor of struct_constructor
66 | | Interface of interface_definition
67 | | Union of union_definition
68 | | Reference of ident located
69 | | FieldAccess of field_access
70 | | FunctionCall of function_call
71 | | MethodCall of method_call
72 | | Function of function_definition
73 | | Int of (Zint.t[@visitors.name "z"])
74 | | Bool of bool
75 | | String of string
76 |
77 | and stmt =
78 | | CodeBlock of (stmt located list[@sexp.list])
79 | | Let of binding located
80 | | DestructuringLet of destructuring_binding located
81 | | Assignment of assignment
82 | | If of if_
83 | | Return of expr located
84 | | Break of stmt located
85 | | Expr of expr located
86 | | Switch of switch
87 | | WhileLoop of while_loop
88 |
89 | and while_loop = {while_cond : expr located; while_body : stmt located}
90 |
91 | and switch =
92 | { switch_condition : expr located;
93 | branches : switch_branch located list;
94 | default : stmt option [@sexp.option] }
95 |
96 | and switch_branch =
97 | {ty : expr located; var : ident located; stmt : stmt located}
98 |
99 | and struct_constructor =
100 | { constructor_id : expr located;
101 | fields_construction : (ident located * expr located) list [@sexp.list]
102 | }
103 |
104 | and struct_field =
105 | { field_attributes : attribute list; [@sexp.list]
106 | field_name : ident located;
107 | field_type : expr located }
108 |
109 | and function_param = ident located * expr located
110 |
111 | and function_definition =
112 | { function_attributes : attribute list; [@sexp.list]
113 | name : ident located option; [@sexp.option]
114 | is_type_function : bool; [@sexp.bool]
115 | params : function_param located list; [@sexp.list]
116 | returns : expr located option; [@sexp.option]
117 | function_body : function_body option; [@sexp.option]
118 | function_def_span : (span[@sexp.opaque]) }
119 |
120 | and function_body = {function_stmt : stmt located}
121 |
122 | and binding = {binding_name : ident located; binding_expr : expr located}
123 |
124 | and destructuring_binding =
125 | { destructuring_binding : (ident located * ident located) list located;
126 | destructuring_binding_expr : expr located;
127 | destructuring_binding_rest : bool }
128 |
129 | and assignment =
130 | { assignment_lvalue : assignment_lvalue located;
131 | assignment_expr : expr located }
132 |
133 | and assignment_lvalue =
134 | | ReferenceLvalue of ident located
135 | | FieldAccessLvalue of ident located * ident located list
136 |
137 | and if_ =
138 | { condition : expr located;
139 | body : stmt located;
140 | else_ : stmt located option [@sexp.option] }
141 |
142 | and field_access = {from_expr : expr located; to_field : ident located}
143 |
144 | and program = {stmts : stmt located list [@sexp.list]}
145 | [@@deriving
146 | show {with_path = false},
147 | make,
148 | sexp_of,
149 | visitors
150 | {variety = "fold"; name = "visitor"; ancestors = ["base_visitor"]}]
151 |
152 | let ident_to_string = function Ident s -> s
153 | end
154 |
--------------------------------------------------------------------------------
/lib/type_check.ml:
--------------------------------------------------------------------------------
1 | open Base
2 |
3 | module Make =
4 | functor
5 | (Config : Config.T)
6 | ->
7 | struct
8 | open Lang_types.Make (Config)
9 |
10 | open Interpreter.Make (Config)
11 |
12 | open Builtin.Make (Config)
13 |
14 | open Errors
15 |
16 | type type_check_error = TypeError of type_ | NeedFromCall of expr
17 |
18 | class ['s] remover_of_resolved_reference =
19 | object (self : 's)
20 | inherit ['s] map as super
21 |
22 | method! visit_ResolvedReference env (_, ex) =
23 | (self#visit_expr env ex).value
24 |
25 | method! visit_type_ env =
26 | function
27 | | ExprType {value = Value (Type t); _} ->
28 | self#visit_type_ env t
29 | | ty ->
30 | super#visit_type_ env ty
31 | end
32 |
33 | let is_sig_part_of sign1 sign2 ~equal_ty =
34 | let remover = new remover_of_resolved_reference in
35 | let sign1 = remover#visit_struct_sig () sign1 in
36 | let sign2 = remover#visit_struct_sig () sign2 in
37 | let is_part = ref true in
38 | List.iter sign2.st_sig_fields ~f:(fun (name2, ty2) ->
39 | if
40 | not
41 | (List.exists sign1.st_sig_fields ~f:(fun (name1, ty1) ->
42 | equal_string name1.value name2.value && equal_ty ty1 ty2 ) )
43 | then is_part := false ) ;
44 | !is_part
45 |
46 | let is_union_sig_part_of sign1 sign2 =
47 | let remover = new remover_of_resolved_reference in
48 | let sign1 = remover#visit_union_sig () sign1 in
49 | let sign2 = remover#visit_union_sig () sign2 in
50 | let is_part = ref true in
51 | List.iter sign2.un_sig_cases ~f:(fun ty2 ->
52 | if not (List.exists sign1.un_sig_cases ~f:(equal_type_ ty2)) then
53 | is_part := false ) ;
54 | !is_part
55 |
56 | class type_checker (errors : _) (functions : _) =
57 | object (self)
58 | val mutable fn_returns : type_ option = None
59 |
60 | method check_return_type ~program ~current_bindings actual =
61 | match fn_returns with
62 | | Some fn_returns' -> (
63 | match
64 | self#check_type (type_of program actual) ~program
65 | ~current_bindings ~expected:fn_returns'
66 | with
67 | | Ok ty ->
68 | fn_returns <- Some ty ;
69 | Ok ty
70 | | v ->
71 | v )
72 | | None ->
73 | ice "Caller should guarantee this"
74 |
75 | method get_fn_returns =
76 | match fn_returns with
77 | | Some x ->
78 | x
79 | | None ->
80 | ice "Caller should guarantee this"
81 |
82 | method with_fn_returns
83 | : 'env 'a. 'env -> type_ -> ('env -> 'a) -> 'a * type_ =
84 | fun env ty f ->
85 | let prev = fn_returns in
86 | fn_returns <- Some ty ;
87 | let result = f env in
88 | let new_fn_returns = self#get_fn_returns in
89 | fn_returns <- prev ;
90 | (result, new_fn_returns)
91 |
92 | method check_type ~program ~current_bindings ~expected actual_ty =
93 | let actual = actual_ty in
94 | let remover = new remover_of_resolved_reference in
95 | let actual' = remover#visit_type_ () actual in
96 | let expected' = remover#visit_type_ () expected in
97 | let is_sig_part_of_call sign_actual sign_expected =
98 | is_sig_part_of sign_actual sign_expected ~equal_ty:(fun ty1 ty2 ->
99 | equal_expr ty1 ty2 )
100 | in
101 | match expected with
102 | | HoleType ->
103 | Ok actual
104 | | _ when equal_type_ HoleType actual' ->
105 | Ok expected
106 | | _ when equal_type_ expected' actual' ->
107 | Ok actual
108 | | StructSig sign_expected -> (
109 | let sign_expected =
110 | Arena.get program.struct_signs sign_expected
111 | in
112 | match actual' with
113 | | StructType sid ->
114 | let s = Program.get_struct program sid in
115 | let sign_actual = sig_of_struct s 0 in
116 | if is_sig_part_of_call sign_actual sign_expected then
117 | Ok (StructType sid)
118 | else Error (TypeError expected)
119 | | ExprType {value = Reference (_, StructSig sid2); _} ->
120 | let sign_actual = Arena.get program.struct_signs sid2 in
121 | if is_sig_part_of_call sign_actual sign_expected then
122 | Ok actual'
123 | else Error (TypeError expected)
124 | | ExprType ({value = FunctionCall _; _} as ex_ty) -> (
125 | let ex_ty = type_of program ex_ty in
126 | match ex_ty with
127 | | StructSig sid2 ->
128 | let sign_actual = Arena.get program.struct_signs sid2 in
129 | if is_sig_part_of_call sign_actual sign_expected then
130 | Ok actual'
131 | else Error (TypeError expected)
132 | | _ ->
133 | Error (TypeError expected) )
134 | | _ ->
135 | Error (TypeError expected) )
136 | | UnionSig sign_expected -> (
137 | let sign_expected = Arena.get program.union_signs sign_expected in
138 | match actual' with
139 | | UnionType sid ->
140 | let s = Program.get_union program sid in
141 | let sign_actual = sig_of_union s in
142 | if is_union_sig_part_of sign_actual sign_expected then
143 | Ok (UnionType sid)
144 | else Error (TypeError expected)
145 | | ExprType {value = Reference (_, UnionSig sid2); _}
146 | | UnionSig sid2 ->
147 | let sign_actual = Arena.get program.union_signs sid2 in
148 | if is_union_sig_part_of sign_actual sign_expected then
149 | Ok (UnionSig sid2)
150 | else Error (TypeError expected)
151 | | _ ->
152 | Error (TypeError expected) )
153 | | TypeN 0 -> (
154 | match actual with
155 | | StructSig _ | Type0 _ ->
156 | Ok actual
157 | | _ -> (
158 | match actual_ty with
159 | | (StructSig _ as ty) | (UnionSig _ as ty) ->
160 | Ok ty
161 | | _ ->
162 | Error (TypeError expected) ) )
163 | | (StructType _ as ty) | (UnionType _ as ty) -> (
164 | let from_intf_ =
165 | let inter =
166 | new interpreter (make_ctx program current_bindings functions)
167 | errors (Config.builtin_located ()).span (fun _ f -> f)
168 | in
169 | Value
170 | (inter#interpret_fc
171 | ( from_intf,
172 | [ { value = Value (Type actual);
173 | span = (Config.builtin_located ()).span } ],
174 | true ) )
175 | in
176 | let impl =
177 | Program.get_uty_details program ty
178 | |> Option.value_exn
179 | |> fun f ->
180 | f.uty_impls
181 | |> List.find_map ~f:(fun i ->
182 | if
183 | equal_expr_kind
184 | (Value (Type (InterfaceType i.impl_interface)))
185 | from_intf_
186 | then Some i.impl_methods
187 | else None )
188 | |> Option.bind ~f:List.hd
189 | in
190 | match impl with
191 | | Some (_, m) ->
192 | Error
193 | (NeedFromCall {value = Value (Function m); span = m.span})
194 | | _ ->
195 | Error (TypeError expected) )
196 | | InterfaceType v -> (
197 | match actual_ty with
198 | | Type0 ty -> (
199 | match Program.find_impl_intf program v ty with
200 | | Some _ ->
201 | Ok actual_ty
202 | | _ ->
203 | Error (TypeError expected) )
204 | | _ ->
205 | Error (TypeError expected) )
206 | | ExprType ex ->
207 | self#check_type ~expected:(type_of program ex) ~program
208 | ~current_bindings actual_ty
209 | | _otherwise ->
210 | Error (TypeError expected)
211 | end
212 | end
213 |
--------------------------------------------------------------------------------
/lib/zint.ml:
--------------------------------------------------------------------------------
1 | include Z
2 |
3 | let pp = Z.pp_print
4 |
5 | let sexp_of_t z = Sexplib.Sexp.of_string (Z.to_string z)
6 |
7 | class ['s] map =
8 | object (_ : 's)
9 | method visit_z : 'env. 'env -> t -> t = fun _env z -> z
10 | end
11 |
12 | let equal = Z.equal
13 |
14 | let hash_fold_t h v = Ppx_hash_lib.Std.Hash.fold_string h @@ Z.to_string v
15 |
--------------------------------------------------------------------------------
/tact.opam:
--------------------------------------------------------------------------------
1 | # This file is generated by dune, edit dune-project instead
2 | opam-version: "2.0"
3 | synopsis: "TON Tact Language"
4 | maintainer: ["cmxog@protonmail.com" "dmytro.polunin@gmail.com"]
5 | authors: ["cmxog@protonmail.com" "dmytro.polunin@gmail.com"]
6 | license: "Apache-2.0"
7 | homepage: "https://github.com/tact-lang/tact"
8 | bug-reports: "https://github.com/tact-lang/tact/issues"
9 | depends: [
10 | "ocaml" {>= "4.14.0"}
11 | "ppx_show" {>= "0.2.1"}
12 | "ppx_make" {>= "0.3.0"}
13 | "ppx_blob" {>= "0.7.2"}
14 | "js_of_ocaml-ppx" {>= "4.0.0"}
15 | "zarith_stubs_js" {>= "0.15.0"}
16 | "dune" {>= "2.9" & build & >= "3.1.1"}
17 | "js_of_ocaml" {>= "4.0.0"}
18 | "mparser" {>= "1.3"}
19 | "zarith" {>= "1.12"}
20 | "base" {>= "0.15.0"}
21 | "ppx_jane" {>= "0.15.0"}
22 | "visitors" {= "20210608"}
23 | "containers" {>= "3.8.0"}
24 | "linenoise" {>= "1.3.1"}
25 | "bos" {>= "0.2.1"}
26 | "cmdliner" {>= "1.1.1"}
27 | "core" {with-test & >= "0.15.0"}
28 | "ppx_expect" {with-test & >= "0.15.0"}
29 | "ppx_matches" {with-test & >= "0.1"}
30 | "alcotest" {with-test & >= "1.5.0"}
31 | "ppx_inline_alcotest" {with-test & >= "1.0.0"}
32 | "utop" {build & >= "2.9.1"}
33 | "ocamlformat" {build & = "0.23.0"}
34 | "odoc" {with-doc}
35 | ]
36 | build: [
37 | ["dune" "subst"] {dev}
38 | [
39 | "dune"
40 | "build"
41 | "-p"
42 | name
43 | "-j"
44 | jobs
45 | "--promote-install-files=false"
46 | "@install"
47 | "@runtest" {with-test}
48 | "@doc" {with-doc}
49 | ]
50 | ["dune" "install" "-p" name "--create-install-files" name]
51 | ]
52 | dev-repo: "git+https://github.com/tact-lang/tact.git"
53 |
--------------------------------------------------------------------------------
/test/builtin_basics.ml:
--------------------------------------------------------------------------------
1 | open Shared.Disabled
2 | module Config = Shared.DisabledConfig
3 |
4 | let find scope name =
5 | let open Config in
6 | List.find_map scope ~f:(fun (n, ex) ->
7 | if equal_string n.value name then Some ex else None )
8 |
9 | let%test "int type equality" =
10 | let source =
11 | {|
12 | let T = Int[257];
13 | let T1 = Int[257];
14 | let T2 = Int[256];
15 | |}
16 | in
17 | Alcotest.(check bool)
18 | "types with same bits are equal" true
19 | (let scope = (compile source).bindings in
20 | let t = find scope "T" |> Option.value_exn
21 | and t1 = find scope "T1" |> Option.value_exn in
22 | pp_sexp (Lang.sexp_of_expr t) ;
23 | pp_sexp (Lang.sexp_of_expr t1) ;
24 | Lang.equal_expr t t1 ) ;
25 | Alcotest.(check bool)
26 | "types with different bits are not equal" false
27 | (let scope = (compile source).bindings in
28 | let t = find scope "T" |> Option.value_exn
29 | and t2 = find scope "T2" |> Option.value_exn in
30 | pp_sexp (Lang.sexp_of_expr t) ;
31 | pp_sexp (Lang.sexp_of_expr t2) ;
32 | Lang.equal_expr t t2 )
33 |
--------------------------------------------------------------------------------
/test/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (package tact)
3 | (preprocess
4 | (staged_pps ppx_matches ppx_expect ppx_sexp_conv))
5 | (name shared)
6 | (inline_tests)
7 | (modules shared)
8 | (libraries tact core sexplib))
9 |
10 | (library
11 | (package tact)
12 | (preprocess
13 | (staged_pps ppx_matches ppx_expect ppx_sexp_conv))
14 | (name tact_tests)
15 | (inline_tests)
16 | (modules syntax immediacy_check builtin lang codegen_func errors)
17 | (libraries tact core sexplib shared))
18 |
19 | (library
20 | (package tact)
21 | (preprocess
22 | (staged_pps ppx_matches ppx_sexp_conv ppx_inline_alcotest))
23 | (name tact_tests_)
24 | (inline_tests)
25 | (modules builtin_basics lang_types std)
26 | (libraries tact core sexplib shared alcotest))
27 |
--------------------------------------------------------------------------------
/test/errors.ml:
--------------------------------------------------------------------------------
1 | module Config = Shared.EnabledConfig
2 | module Show = Tact.Show.Make (Shared.EnabledConfig)
3 | open Config
4 | open Base
5 |
6 | let fmt = Caml.Format.std_formatter
7 |
8 | let%expect_test "error showing one line" =
9 | let source = {|
10 | fn test() {
11 |
12 | }
13 | |} in
14 | let open Show.DiagnosticMsg in
15 | let pos1 : Tact.Located.pos =
16 | {pos_fname = "f"; pos_cnum = 3 + 1; pos_lnum = 1; pos_bol = 1}
17 | in
18 | let pos2 : Tact.Located.pos =
19 | {pos_fname = "f"; pos_cnum = 7 + 1; pos_lnum = 1; pos_bol = 1}
20 | in
21 | let msg =
22 | { severity = `Error;
23 | diagnostic_id = 0;
24 | diagnostic_msg = "msg";
25 | spans = [(span_of_concrete (pos1, pos2), "message")];
26 | additional_msg = [] }
27 | in
28 | Show.DiagnosticMsg.show fmt msg source ;
29 | [%expect
30 | {|
31 | Error[0]: msg
32 | File: "f":1:3
33 | |
34 | 1 | fn test() {
35 | | ^^^^ message |}]
36 |
37 | let%expect_test "error showing two lines" =
38 | let source = {|
39 | let a = test(
40 | arg1, arg2);
41 | |} in
42 | let open Show.DiagnosticMsg in
43 | let pos1 : Tact.Located.pos =
44 | {pos_fname = "f"; pos_cnum = 8 + 1; pos_lnum = 1; pos_bol = 1}
45 | in
46 | let pos2 : Tact.Located.pos =
47 | {pos_fname = "f"; pos_cnum = 13 + 13 + 1; pos_lnum = 2; pos_bol = 13 + 1}
48 | in
49 | let msg =
50 | { severity = `Error;
51 | diagnostic_id = 0;
52 | diagnostic_msg = "msg";
53 | spans = [(span_of_concrete (pos1, pos2), "message")];
54 | additional_msg = [] }
55 | in
56 | Show.DiagnosticMsg.show fmt msg source ;
57 | [%expect
58 | {|
59 | Error[0]: msg
60 | File: "f":1:8
61 | |
62 | 1 | let a = test(...
63 | | ^^^^^^^^ message |}]
64 |
65 | let pp =
66 | let open Base in
67 | Shared.Enabled.pp_compile ~show_errors:(fun (elist, _) source ->
68 | List.iter elist ~f:(fun x ->
69 | let s = Show.show_error source x in
70 | Caml.Format.print_string s ) )
71 |
72 | let handle_parse_error (f : unit -> unit) =
73 | match f () with
74 | | value ->
75 | value
76 | | exception Shared.Enabled.Parser.Error (msg, _) ->
77 | Caml.print_string msg
78 |
79 | let%expect_test "failed scope resolution" =
80 | let source = {|
81 | let T = IntN256;
82 | |} in
83 | pp source ;
84 | [%expect
85 | {|
86 | Error[1]: Unresolved identifier IntN256
87 | File: "":2:12
88 | |
89 | 2 | let T = IntN256;
90 | | ^^^^^^^ Cannot resolve this identifier |}]
91 |
92 | let%expect_test "method not found" =
93 | let source = {|
94 | struct St { }
95 |
96 | let _ = St{}.method();
97 | |} in
98 | pp source ;
99 | [%expect
100 | {|
101 | Error[1]: Method method not found in
102 | File: "":4:19
103 | |
104 | 4 | let _ = St{}.method();
105 | | ^^^^^^ Method not found |}]
106 |
107 | let%expect_test "duplicate field" =
108 | let source =
109 | {|
110 | struct Foo {
111 | val field: Integer
112 | val field: Integer
113 | }
114 | |}
115 | in
116 | pp source ;
117 | [%expect
118 | {|
119 | Error[1]: Duplicate struct field field
120 | File: "":3:12
121 | |
122 | 3 | val field: Integer
123 | | ^^^^^ Duplicated |}]
124 |
125 | let%expect_test "duplicate variant" =
126 | let source =
127 | {|
128 | union Test1 {
129 | case Integer
130 | case Integer
131 | }
132 |
133 | union Test2[T: Type] {
134 | case Integer
135 | case T
136 | }
137 | let _ = Test2[Integer];
138 | |}
139 | in
140 | pp source ;
141 | [%expect
142 | {|
143 | Error[1]: Duplicate variant with type Integer
144 | File: "":2:6
145 | |
146 | 2 | union Test1 {...
147 | | ^^^^^^^^^^^^^^^^ Duplicated variant in this union
148 | Error[1]: Duplicate variant with type Integer
149 | File: "":11:14
150 | |
151 | 11 | let _ = Test2[Integer];
152 | | ^^^^^^^^^^^^^ Duplicated variant in this union |}]
153 |
154 | let%expect_test "type errors" =
155 | let source =
156 | {|
157 | struct Test {}
158 |
159 | fn test1() -> Test {
160 | 123
161 | }
162 |
163 | fn test2() -> Test {
164 | return 123;
165 | }
166 |
167 | fn expect_test(t: Test) {}
168 | expect_test(123);
169 | |}
170 | in
171 | pp source ~include_std:false ;
172 | [%expect
173 | {|
174 | Error[1]: Expected type `` but found `Integer`
175 | File: "":5:8
176 | |
177 | 5 | 123...
178 | | ^^^^^^ This has type `Integer`
179 | Error[1]: Expected type `` but found `Integer`
180 | File: "":9:15
181 | |
182 | 9 | return 123;
183 | | ^^^ This has type `Integer`
184 | Error[1]: Expected type `` but found `Integer`
185 | File: "":13:18
186 | |
187 | 13 | expect_test(123);
188 | | ^^^ This has type `Integer` |}]
189 |
190 | let%expect_test "is not a struct error" =
191 | let source =
192 | {|
193 | fn test() { 123 }
194 | let a = test() { field: 123 };
195 | |}
196 | in
197 | pp source ~include_std:false ;
198 | [%expect
199 | {|
200 | Error[1]: Expression is not struct type, so it cannot be used in such context.
201 | File: "":3:14
202 | |
203 | 3 | let a = test() { field: 123 };
204 | | ^^^^ This is not struct type |}]
205 |
206 | let%expect_test "cannot have methods error" =
207 | let source = {|
208 | 123.test();
209 | |} in
210 | pp source ~include_std:false ;
211 | [%expect
212 | {|
213 | Error[1]: Method test not found in 123
214 | File: "":2:10
215 | |
216 | 2 | 123.test();
217 | | ^^^^ Method not found |}]
218 |
219 | let%expect_test "this cannot be called error" =
220 | let source = {|
221 | 123();
222 | |} in
223 | pp source ~include_std:false ;
224 | [%expect
225 | {|
226 | Error[1]: Expected function but got value with `Integer` type.
227 | File: "":2:6
228 | |
229 | 2 | 123();
230 | | ^^^ This cannot be called |}]
231 |
232 | let%expect_test "argument number mismatch" =
233 | let source = {|
234 | fn test(x: Integer) {}
235 | test(10, 20, 30);
236 | |} in
237 | pp source ~include_std:false ;
238 | [%expect
239 | {|
240 | Error[1]: Expected 1 arguments but found 3.
241 | File: "":3:6
242 | |
243 | 3 | test(10, 20, 30);
244 | | ^^^^ When calling this function |}]
245 |
246 | (* FIXME: this should print error. *)
247 | let%expect_test "uninterpretable statement" =
248 | let source =
249 | {|
250 | fn test() { builtin_begin_cell(); }
251 | test();
252 | |}
253 | in
254 | pp source ~include_std:false ;
255 | [%expect
256 | {|
257 | (Ok
258 | ((bindings
259 | ((((span (pos pos)) (value test))
260 | ((span (pos pos))
261 | (value
262 | (Value
263 | (Function
264 | ((span (pos pos))
265 | (value
266 | ((function_signature
267 | ((span (pos pos))
268 | (value ((function_params ()) (function_returns HoleType)))))
269 | (function_impl
270 | (Fn
271 | ((span (pos pos))
272 | (value
273 | (Return
274 | ((span (pos pos))
275 | (value
276 | (FunctionCall
277 | (((span (pos pos))
278 | (value
279 | (ResolvedReference
280 | (((span (pos pos)) (value builtin_begin_cell))
281 | ))))
282 | () false)))))))))))))))))))
283 | (structs ()) (type_counter ) (memoized_fcalls )
284 | (struct_signs (0 ())) (union_signs (0 ())) (attr_executors ))) |}]
285 |
286 | let%expect_test "field not found" =
287 | let source =
288 | {|
289 | struct Empty {}
290 | let _ = Empty{}.field;
291 | let {field} = Empty{};
292 | |}
293 | in
294 | pp source ~include_std:false ;
295 | [%expect
296 | {|
297 | Error[1]: Field `field` not found.
298 | File: "":3:22
299 | |
300 | 3 | let _ = Empty{}.field;
301 | | ^^^^^ This field not found
302 | Error[1]: Field `field` not found.
303 | File: "":4:11
304 | |
305 | 4 | let {field} = Empty{};
306 | | ^^^^^ This field not found |}]
307 |
308 | let%expect_test "missing field error" =
309 | let source =
310 | {|
311 | struct Test { val field: Integer }
312 | let {} = Test{field: 10};
313 | |}
314 | in
315 | pp source ~include_std:false ;
316 | [%expect
317 | {|
318 | Error[1]: Field `field` missing in destructuring statement.
319 | File: "":3:6
320 | |
321 | 3 | let {} = Test{field: 10};
322 | | ^^^^^^^^^^^^^^^^^^^^^^^^ In this binding |}]
323 |
324 | let%expect_test "Case Not Found Error" =
325 | let source =
326 | {|
327 | union Test {
328 | case Int[10]
329 | case Int[20]
330 | }
331 | fn test(value: Test) {
332 | switch (value) {
333 | case Int[10] _ => { return 10; }
334 | case Int[123] _ => { return 123; }
335 | }
336 | }
337 | |}
338 | in
339 | pp source ;
340 | [%expect
341 | {|
342 | Error[1]: Case type not found in union.
343 | File: "":9:24
344 | |
345 | 9 | case Int[123] _ => { return 123; }
346 | | ^ Type of this variable is not found in the condition union |}]
347 |
348 | let%expect_test "Expected Type Function" =
349 | let source =
350 | {|
351 | union Test[X: Type] {}
352 |
353 | let _ = Test(Integer);
354 | |}
355 | in
356 | pp source ;
357 | [%expect
358 | {|
359 | Error[1]: Function should be called using `[]` brackets but called with `()` parens.
360 | File: "":4:14
361 | |
362 | 4 | let _ = Test(Integer);
363 | | ^^^^^^^^^^^^ When calling this function |}]
364 |
365 | let%expect_test "Proper error positioning for ambigiously defined data types" =
366 | let sources =
367 | [ {|
368 | struct T {v}
369 | |};
370 | {|
371 | interface I {i}
372 | |};
373 | {|
374 | union U {u}
375 | |} ]
376 | in
377 | List.iter sources ~f:(fun s -> handle_parse_error (fun () -> pp s)) ;
378 | [%expect
379 | {|
380 | Error in line 2, column 17:
381 | struct T {v}
382 | ^
383 | Expecting "//", "fn", "impl", "val", '@', '}', block comment or whitespace
384 | Error in line 2, column 20:
385 | interface I {i}
386 | ^
387 | Expecting "//", "fn", '@', '}', block comment or whitespace
388 | Error in line 2, column 16:
389 | union U {u}
390 | ^
391 | Expecting "//", "case", "fn", "impl", '@', '}', block comment or whitespace |}]
392 |
--------------------------------------------------------------------------------
/test/immediacy_check.ml:
--------------------------------------------------------------------------------
1 | module Config = struct
2 | include Tact.Located.Disabled
3 | end
4 |
5 | module Syntax = Tact.Syntax.Make (Config)
6 | module Parser = Tact.Parser.Make (Config)
7 | module Lang = Tact.Lang.Make (Config)
8 | module Show = Tact.Show.Make (Config)
9 | module Interpreter = Tact.Interpreter.Make (Config)
10 | module Errors = Tact.Errors
11 | module Zint = Tact.Zint
12 | module C = Tact.Compiler
13 | module Codegen = Tact.Codegen_func
14 | module Func = Tact.Func
15 | include Core
16 |
17 | type error = [Lang.error | Interpreter.error] [@@deriving sexp_of]
18 |
19 | let make_errors e = new Errors.errors e
20 |
21 | let parse_program s = Parser.parse s
22 |
23 | let strip_if_exists_in_other o1 o2 ~equal =
24 | List.filter o1 ~f:(fun o1_item -> not @@ List.exists o2 ~f:(equal o1_item))
25 |
26 | let strip : program:Lang.program -> previous:Lang.program -> Lang.program =
27 | fun ~program ~previous ->
28 | { program with
29 | bindings =
30 | strip_if_exists_in_other program.bindings previous.bindings
31 | ~equal:(fun (x1, _) (y1, _) -> Config.equal_located equal_string x1 y1);
32 | structs =
33 | strip_if_exists_in_other program.structs previous.structs
34 | ~equal:(fun (id1, _) (id2, _) -> equal_int id1 id2);
35 | unions =
36 | strip_if_exists_in_other program.unions previous.unions
37 | ~equal:(fun (id1, _) (id2, _) -> equal_int id1 id2);
38 | interfaces =
39 | strip_if_exists_in_other program.interfaces previous.interfaces
40 | ~equal:(fun (id1, _) (id2, _) -> equal_int id1 id2);
41 | struct_signs =
42 | Lang.Arena.strip_if_exists program.struct_signs previous.struct_signs;
43 | union_signs =
44 | Lang.Arena.strip_if_exists program.union_signs previous.struct_signs }
45 |
46 | let compile_pass p prev_program errors =
47 | let c = new Lang.constructor ~program:prev_program errors in
48 | let p' = c#visit_program Lang.default_ctx p in
49 | p'
50 |
51 | let build_program ?(errors = make_errors Show.show_error)
52 | ?(strip_defaults = true) ~codegen p =
53 | let p' = compile_pass p (Lang.default_program ()) errors in
54 | let p'' =
55 | if strip_defaults then strip ~program:p' ~previous:(Lang.default_program ())
56 | else p'
57 | in
58 | errors#to_result p''
59 | |> Result.map_error ~f:(fun errors ->
60 | let errs = List.map errors ~f:(fun (_, err, _) -> err) in
61 | (errs, p'') )
62 | |> Result.map ~f:codegen
63 |
64 | let rec pp_sexp = Sexplib.Sexp.pp_hum Caml.Format.std_formatter
65 |
66 | and sexp_of_errors =
67 | sexp_of_pair (List.sexp_of_t sexp_of_error) Lang.sexp_of_program
68 |
69 | and print_sexp e =
70 | pp_sexp (Result.sexp_of_t Lang.sexp_of_program sexp_of_errors e)
71 |
72 | let compile ?(strip_defaults = true) s =
73 | parse_program s |> build_program ~strip_defaults ~codegen:(fun x -> x)
74 |
75 | let pp_compile ?(strip_defaults = true) s =
76 | compile ~strip_defaults s |> print_sexp
77 |
78 | open Lang
79 |
80 | let%expect_test "Immediacy Checks Comptime Reference" =
81 | let scope = [[make_comptime (bl "Test", bl @@ Value Void)]] in
82 | let expr = bl @@ Reference (bl "Test", VoidType) in
83 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
84 | [%expect {| true |}]
85 |
86 | let%expect_test "Immediacy Checks Runtime Reference" =
87 | let scope = [[make_runtime (bl "Test", VoidType)]] in
88 | let expr = bl @@ Reference (bl "Test", VoidType) in
89 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
90 | [%expect {| false |}]
91 |
92 | let%expect_test "Immediacy Checks Primitive" =
93 | let scope = [] in
94 | let expr =
95 | bl @@ Primitive (Prim {name = ""; exprs = []; out_ty = VoidType})
96 | in
97 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
98 | [%expect {| false |}]
99 |
100 | let%expect_test "Immediacy Checks Empty Function" =
101 | let scope = [] in
102 | let expr =
103 | bl
104 | @@ Value
105 | (Function
106 | ( bl
107 | @@ { function_signature =
108 | bl
109 | @@ { function_attributes = [];
110 | function_is_type = false;
111 | function_params = [];
112 | function_returns = VoidType };
113 | function_impl = Fn (bl @@ Block []) } ) )
114 | in
115 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
116 | [%expect {| true |}]
117 |
118 | let%expect_test "Immediacy Checks Function Argument" =
119 | let scope = [] in
120 | let expr =
121 | bl
122 | @@ Value
123 | (Function
124 | ( bl
125 | @@ { function_signature =
126 | bl
127 | @@ { function_attributes = [];
128 | function_params = [(bl "arg", VoidType)];
129 | function_is_type = false;
130 | function_returns = VoidType };
131 | function_impl =
132 | Fn
133 | ( bl
134 | @@ Block [bl @@ Expr (bl @@ Reference (bl "arg", VoidType))]
135 | ) } ) )
136 | in
137 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
138 | [%expect {| true |}]
139 |
140 | let%expect_test "Immediacy Checks Let Argument" =
141 | let scope = [] in
142 | let expr =
143 | bl
144 | @@ Value
145 | (Function
146 | ( bl
147 | @@ { function_signature =
148 | bl
149 | @@ { function_attributes = [];
150 | function_params = [];
151 | function_is_type = false;
152 | function_returns = VoidType };
153 | function_impl =
154 | Fn
155 | ( bl
156 | @@ Block
157 | [ bl @@ Let [(bl "arg", bl @@ Value Void)];
158 | bl @@ Expr (bl @@ Reference (bl "arg", VoidType)) ]
159 | ) } ) )
160 | in
161 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
162 | [%expect {| true |}]
163 |
164 | let%expect_test "Immediacy Checks Destructuring Let" =
165 | let scope = [] in
166 | let expr =
167 | bl
168 | @@ Value
169 | (Function
170 | ( bl
171 | @@ { function_signature =
172 | bl
173 | @@ { function_attributes = [];
174 | function_params = [];
175 | function_is_type = false;
176 | function_returns = VoidType };
177 | function_impl =
178 | Fn
179 | ( bl
180 | @@ Block
181 | [ bl
182 | @@ DestructuringLet
183 | { destructuring_let =
184 | [(bl "a", bl "b"); (bl "c", bl "c")];
185 | destructuring_let_rest = false;
186 | destructuring_let_expr = bl @@ Value Void };
187 | bl @@ Expr (bl @@ Reference (bl "b", VoidType));
188 | bl @@ Expr (bl @@ Reference (bl "c", VoidType)) ] )
189 | } ) )
190 | in
191 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
192 | [%expect {| true |}]
193 |
194 | let%expect_test "Immediacy Checks Function Call WITHOUT Primitive" =
195 | let scope = [] in
196 | let expr =
197 | bl
198 | @@ FunctionCall
199 | ( bl
200 | @@ Value
201 | (Function
202 | ( bl
203 | @@ { function_signature =
204 | bl
205 | @@ { function_attributes = [];
206 | function_params = [];
207 | function_is_type = false;
208 | function_returns = VoidType };
209 | function_impl =
210 | Fn
211 | ( bl
212 | @@ Block
213 | [ bl @@ Let [(bl "arg", bl @@ Value Void)];
214 | bl
215 | @@ Expr (bl @@ Reference (bl "arg", VoidType))
216 | ] ) } ) ),
217 | [],
218 | false )
219 | in
220 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
221 | [%expect {| true |}]
222 |
223 | let%expect_test "Immediacy Checks Function Call WITH Primitive" =
224 | let scope = [] in
225 | let expr =
226 | bl
227 | @@ FunctionCall
228 | ( bl
229 | @@ Value
230 | (Function
231 | ( bl
232 | @@ { function_signature =
233 | bl
234 | @@ { function_attributes = [];
235 | function_params = [];
236 | function_is_type = false;
237 | function_returns = VoidType };
238 | function_impl =
239 | Fn
240 | ( bl
241 | @@ Block
242 | [ bl
243 | @@ Expr
244 | ( bl
245 | @@ Primitive
246 | (Prim
247 | { name = "";
248 | exprs = [];
249 | out_ty = VoidType } ) ) ] ) }
250 | ) ),
251 | [],
252 | false )
253 | in
254 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
255 | [%expect {| false |}]
256 |
257 | let f_with_primitive =
258 | bl
259 | @@ Value
260 | (Function
261 | ( bl
262 | @@ { function_signature =
263 | bl
264 | @@ { function_attributes = [];
265 | function_params = [];
266 | function_is_type = false;
267 | function_returns = VoidType };
268 | function_impl =
269 | Fn
270 | ( bl
271 | @@ Block
272 | [ bl
273 | @@ Expr
274 | ( bl
275 | @@ Primitive
276 | (Prim
277 | {name = ""; exprs = []; out_ty = VoidType}
278 | ) ) ] ) } ) )
279 |
280 | let%expect_test "Immediacy Checks Function Call that contains function with \
281 | primitive" =
282 | let scope = [] in
283 | let expr =
284 | bl
285 | @@ FunctionCall
286 | ( bl
287 | @@ Value
288 | (Function
289 | ( bl
290 | @@ { function_signature =
291 | bl
292 | @@ { function_attributes = [];
293 | function_is_type = false;
294 | function_params = [];
295 | function_returns = VoidType };
296 | function_impl =
297 | Fn
298 | ( bl
299 | @@ Block [bl @@ Let [(bl "_", f_with_primitive)]] )
300 | } ) ),
301 | [],
302 | false )
303 | in
304 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
305 | [%expect {| true |}]
306 |
307 | let%expect_test "Immediacy Checks Function Call that Call function with \
308 | primitive" =
309 | let scope = [] in
310 | let expr =
311 | bl
312 | @@ FunctionCall
313 | ( bl
314 | @@ Value
315 | (Function
316 | ( bl
317 | @@ { function_signature =
318 | bl
319 | @@ { function_attributes = [];
320 | function_is_type = false;
321 | function_params = [];
322 | function_returns = VoidType };
323 | function_impl =
324 | Fn
325 | ( bl
326 | @@ Block
327 | [ bl
328 | @@ Expr
329 | ( bl
330 | @@ FunctionCall
331 | (f_with_primitive, [], false) ) ]
332 | ) } ) ),
333 | [],
334 | false )
335 | in
336 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
337 | [%expect {| false |}]
338 |
339 | let%expect_test "Immediacy Checks Top Level Fn With Sign" =
340 | let scope = [] in
341 | let expr =
342 | bl
343 | @@ Value
344 | (Function
345 | ( bl
346 | @@ { function_signature =
347 | bl
348 | @@ { function_attributes = [];
349 | function_is_type = false;
350 | function_params = [];
351 | function_returns = StructSig 0 };
352 | function_impl = Fn (bl @@ Block []) } ) )
353 | in
354 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
355 | [%expect {| true |}]
356 |
357 | let%expect_test "Immediacy Checks Struct Sig" =
358 | let scope = [] in
359 | let expr = bl @@ Value (Type (StructSig 0)) in
360 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
361 | [%expect {| false |}]
362 |
363 | let%expect_test "Immediacy Checks Self Type" =
364 | let scope = [] in
365 | let expr =
366 | bl @@ FunctionCall (bl @@ Value Void, [bl @@ Value (Type SelfType)], false)
367 | in
368 | pp_sexp @@ sexp_of_bool @@ is_immediate_expr scope (default_program ()) expr ;
369 | [%expect {| false |}]
370 |
371 | (* let%expect_test "Immediacy Checks MyInt Type" =
372 | let source =
373 | {|
374 | struct Cell {
375 | val c: builtin_Cell
376 | }
377 | struct Builder {
378 | val b: builtin_Builder
379 | fn serialize_int(self: Self, int: Integer, bits: Integer) -> Self {
380 | let b = builtin_store_int(self.b, int, bits);
381 | Self { b: b }
382 | }
383 | }
384 |
385 | struct Slice {
386 | val s: builtin_Slice
387 | fn load_int(self: Self, bits: Integer) -> LoadResult(Integer) {
388 | let output = builtin_load_int(self.s, bits);
389 | let slice = Self { s: output.value1 };
390 | let int = output.value2;
391 | LoadResult(Integer) { slice: slice, value: int }
392 | }
393 | }
394 | struct MyInt[bits: Integer] {
395 | val value: Integer
396 | impl Deserialize {
397 | fn deserialize(s: Slice) -> LoadResult(Self) {
398 | let res = s.load_int(bits);
399 |
400 | LoadResult(Self) {
401 | slice: res.slice,
402 | value: Self { value: res.value }
403 | }
404 | }
405 | }
406 | }
407 | |}
408 | in
409 | let p = Option.value_exn @@ Result.ok @@ compile source in
410 | let res =
411 | is_immediate_expr
412 | [List.map p.bindings ~f:make_comptime]
413 | p
414 | ( bl
415 | @@ FunctionCall
416 | ( List.Assoc.find_exn p.bindings (bl @@ "MyInt")
417 | ~equal:(Config.equal_located equal_string),
418 | [bl @@ Value (Integer (Z.of_int 123))] ) )
419 | in
420 | pp_sexp @@ sexp_of_bool res ;
421 | [%expect {| true |}] *)
422 |
423 | let%expect_test "Immediacy Checks Unions Functions" =
424 | let source =
425 | {|
426 | union MsgAddressExt {
427 | case Integer
428 | fn serialize(self: Self) { }
429 | }
430 | |}
431 | in
432 | let _ = Option.value_exn @@ Result.ok @@ compile source in
433 | pp_sexp @@ sexp_of_bool true ;
434 | [%expect {| true |}]
435 |
436 | let%expect_test "Immediacy Checks Unions Functions" =
437 | let source =
438 | {|
439 | union MsgAddressExt {
440 | case Integer
441 | fn serialize(self: Self) { }
442 | }
443 | |}
444 | in
445 | let _ = Option.value_exn @@ Result.ok @@ compile source in
446 | pp_sexp @@ sexp_of_bool true ;
447 | [%expect {| true |}]
448 |
--------------------------------------------------------------------------------
/test/lang_types.ml:
--------------------------------------------------------------------------------
1 | open Shared.Disabled
2 | open Shared.Disabled.Lang
3 | module Config = Shared.DisabledConfig
4 |
5 | let find scope name =
6 | let open Config in
7 | List.find_map scope ~f:(fun (n, ex) ->
8 | if equal_string n.value name then Some ex else None )
9 |
10 | let%test "aliased structures equality" =
11 | let source = {|
12 | struct T { val a: Int[257] }
13 | let T1 = T;
14 | |} in
15 | Alcotest.(check bool)
16 | "aliased types are the same" true
17 | (let scope = (compile source).bindings in
18 | let t = find scope "T" |> Option.value_exn
19 | and t1 = find scope "T1" |> Option.value_exn in
20 | pp_sexp (Lang.sexp_of_expr t) ;
21 | pp_sexp (Lang.sexp_of_expr t1) ;
22 | Lang.equal_expr t t1 )
23 |
24 | let%test "carbon copy structure equality" =
25 | let source =
26 | {|
27 | struct T { val a: Int[257] }
28 | struct T1 { val a: Int[257] }
29 | |}
30 | in
31 | Alcotest.(check bool)
32 | "carbon copy types are not the same" false
33 | (let scope = (compile source).bindings in
34 | let t = find scope "T" |> Option.value_exn
35 | and t1 = find scope "T1" |> Option.value_exn in
36 | pp_sexp (Lang.sexp_of_expr t) ;
37 | pp_sexp (Lang.sexp_of_expr t1) ;
38 | Lang.equal_expr t t1 )
39 |
40 | let%test "parameterized structure equality" =
41 | let source =
42 | {|
43 | struct T[X: Type] { val a: X }
44 | let T1 = T[Int[257]];
45 | let T2 = T[Bool];
46 | let T3 = T[Int[257]];
47 | |}
48 | in
49 | Alcotest.(check bool)
50 | "differently parameterized types are not the same" false
51 | (let scope = (compile source).bindings in
52 | let t1 = find scope "T1" |> Option.value_exn
53 | and t2 = find scope "T2" |> Option.value_exn in
54 | pp_sexp (Lang.sexp_of_expr t1) ;
55 | pp_sexp (Lang.sexp_of_expr t2) ;
56 | Lang.equal_expr t1 t2 ) ;
57 | Alcotest.(check bool)
58 | "equally parameterized types are the same" true
59 | (let scope = (compile source).bindings in
60 | let t1 = find scope "T1" |> Option.value_exn
61 | and t3 = find scope "T3" |> Option.value_exn in
62 | pp_sexp (Lang.sexp_of_expr t1) ;
63 | pp_sexp (Lang.sexp_of_expr t3) ;
64 | Lang.equal_expr t1 t3 )
65 |
66 | let%test "builtin function equality" =
67 | let bl = Config.builtin_located in
68 | let f1 =
69 | { function_signature =
70 | bl
71 | { function_attributes = [];
72 | function_is_type = false;
73 | function_params = [];
74 | function_returns = VoidType };
75 | function_impl = BuiltinFn (builtin_fun (fun _ _ -> Void)) }
76 | and f2 =
77 | { function_signature =
78 | bl
79 | { function_attributes = [];
80 | function_is_type = false;
81 | function_params = [];
82 | function_returns = VoidType };
83 | function_impl = BuiltinFn (builtin_fun (fun _ _ -> Void)) }
84 | in
85 | Alcotest.(check bool)
86 | "different instances of the same builtin function are not equal" false
87 | (equal_function_kind f1 f2) ;
88 | Alcotest.(check bool)
89 | "same instances of the same builtin function are equal" true
90 | (equal_function_kind f1 f1)
91 |
--------------------------------------------------------------------------------
/test/shared.ml:
--------------------------------------------------------------------------------
1 | module Make =
2 | functor
3 | (Config : Tact.Config.T)
4 | ->
5 | struct
6 | module Syntax = Tact.Syntax.Make (Config)
7 | module Parser = Tact.Parser.Make (Config)
8 | module Lang = Tact.Lang.Make (Config)
9 | module Show = Tact.Show.Make (Config)
10 | module Interpreter = Tact.Interpreter.Make (Config)
11 | module Builtin = Tact.Builtin.Make (Config)
12 | module Codegen = Tact.Codegen_func.Make (Config)
13 | module Errors = Tact.Errors
14 | module Zint = Tact.Zint
15 | module Func = Tact.Func
16 | include Core
17 |
18 | type error = [Lang.error | Interpreter.error] [@@deriving sexp_of]
19 |
20 | let make_errors e = new Errors.errors e
21 |
22 | let parse_program s = Parser.parse s
23 |
24 | let strip_if_exists_in_other o1 o2 ~equal =
25 | List.filter o1 ~f:(fun o1_item ->
26 | not @@ List.exists o2 ~f:(equal o1_item) )
27 |
28 | let strip : program:Lang.program -> previous:Lang.program -> Lang.program =
29 | fun ~program ~previous ->
30 | { program with
31 | bindings =
32 | strip_if_exists_in_other program.bindings previous.bindings
33 | ~equal:(fun (x1, _) (y1, _) ->
34 | Config.equal_located equal_string x1 y1 );
35 | structs =
36 | strip_if_exists_in_other program.structs previous.structs
37 | ~equal:(fun (id1, _) (id2, _) -> equal_int id1 id2);
38 | unions =
39 | strip_if_exists_in_other program.unions previous.unions
40 | ~equal:(fun (id1, _) (id2, _) -> equal_int id1 id2);
41 | interfaces =
42 | strip_if_exists_in_other program.interfaces previous.interfaces
43 | ~equal:(fun (id1, _) (id2, _) -> equal_int id1 id2);
44 | type_functions =
45 | strip_if_exists_in_other program.type_functions
46 | previous.type_functions ~equal:(fun (id1, _) (id2, _) ->
47 | Lang.equal_type_ id1 id2 );
48 | struct_signs =
49 | Lang.Arena.strip_if_exists program.struct_signs previous.struct_signs;
50 | union_signs =
51 | Lang.Arena.strip_if_exists program.union_signs previous.union_signs }
52 |
53 | let compile_pass p prev_program errors =
54 | let c = new Lang.constructor ~program:prev_program errors in
55 | let p' = c#visit_program Lang.default_ctx p in
56 | p'
57 |
58 | let build_program ?(errors = make_errors Show.show_error)
59 | ?(prev_program = Lang.default_program ()) ?(strip_defaults = true)
60 | ~include_std ~codegen p =
61 | let prev_prog =
62 | match include_std with
63 | | true ->
64 | let c = new Lang.constructor ~program:prev_program errors in
65 | let p' =
66 | c#visit_program Lang.default_ctx (parse_program Builtin.std)
67 | in
68 | p'
69 | | false ->
70 | prev_program
71 | in
72 | (* This will make a deep copy. Lang.constructor mutates input program,
73 | so we need deep copy if we want to strip bindings later. *)
74 | let prev_prog_copy =
75 | { prev_prog with
76 | bindings = prev_prog.bindings;
77 | struct_signs = Lang.Arena.deep_copy prev_prog.struct_signs;
78 | union_signs = Lang.Arena.deep_copy prev_prog.union_signs }
79 | in
80 | let p' = compile_pass p prev_prog_copy errors in
81 | let p'' =
82 | if strip_defaults then strip ~program:p' ~previous:prev_prog else p'
83 | in
84 | errors#to_result p''
85 | |> Result.map_error ~f:(fun errors ->
86 | let errs = List.map errors ~f:(fun (_, err, _) -> err) in
87 | (errs, p'') )
88 | |> Result.map ~f:codegen
89 |
90 | let rec pp_sexp = Sexplib.Sexp.pp_hum Caml.Format.std_formatter
91 |
92 | and sexp_of_errors =
93 | sexp_of_pair (List.sexp_of_t sexp_of_error) Lang.sexp_of_program
94 |
95 | and print_sexp e =
96 | pp_sexp (Result.sexp_of_t Lang.sexp_of_program sexp_of_errors e)
97 |
98 | let pp_compile ?(prev_program = Lang.default_program ())
99 | ?(strip_defaults = true) ?(include_std = true)
100 | ?(show_errors = fun x _ -> pp_sexp (sexp_of_errors x)) s =
101 | parse_program s
102 | |> build_program ~prev_program ~strip_defaults ~include_std
103 | ~codegen:(fun x -> x)
104 | |> fun res ->
105 | ( match res with
106 | | Ok t ->
107 | pp_sexp @@ Result.sexp_of_t Lang.sexp_of_program sexp_of_errors (Ok t)
108 | | Error e ->
109 | show_errors e s ) ;
110 | Caml.print_newline ()
111 |
112 | let pp_codegen ?(prev_program = Lang.default_program ())
113 | ?(strip_defaults = false) ?(include_std = true) s =
114 | let _ =
115 | parse_program s
116 | |> build_program ~prev_program ~strip_defaults ~include_std
117 | ~codegen:Codegen.codegen
118 | |> Result.map ~f:(Func.pp_program Caml.Format.std_formatter)
119 | |> Result.map_error ~f:(fun e -> pp_sexp (sexp_of_errors e))
120 | in
121 | ()
122 |
123 | exception Exn of error list * Lang.program
124 |
125 | let compile s =
126 | parse_program s
127 | |> build_program ~codegen:(fun x -> x) ~include_std:true
128 | |> Result.map_error ~f:(fun (errs, p) -> Exn (errs, p))
129 | |> Result.ok_exn
130 | end
131 |
132 | module EnabledConfig = struct
133 | include Tact.Located.Enabled
134 | end
135 |
136 | module DisabledConfig = struct
137 | include Tact.Located.Disabled
138 | end
139 |
140 | module Enabled = Make (EnabledConfig)
141 | module Disabled = Make (DisabledConfig)
142 |
--------------------------------------------------------------------------------
/test/std.ml:
--------------------------------------------------------------------------------
1 | module Config = struct
2 | include Tact.Located.Disabled
3 | end
4 |
5 | module Syntax = Tact.Syntax.Make (Config)
6 | module Parser = Tact.Parser.Make (Config)
7 | module Lang = Tact.Lang.Make (Config)
8 | module Show = Tact.Show.Make (Config)
9 | module Interpreter = Tact.Interpreter.Make (Config)
10 | module Builtin = Tact.Builtin.Make (Config)
11 | module Errors = Tact.Errors
12 | module Zint = Tact.Zint
13 | module C = Tact.Compiler
14 | include Core
15 |
16 | type error = [Lang.error | Interpreter.error] * Lang.program
17 | [@@deriving sexp_of]
18 |
19 | let make_errors e = new Errors.errors e
20 |
21 | let parse_program s = Parser.parse s
22 |
23 | let pp_sexp = Sexplib.Sexp.pp_hum Caml.Format.std_formatter
24 |
25 | let compile_std ?(errors = make_errors Show.show_error)
26 | ?(prev_program = Lang.default_program ()) () =
27 | let std =
28 | let c = new Lang.constructor ~program:prev_program errors in
29 | let p' = c#visit_program Lang.default_ctx (parse_program Builtin.std) in
30 | p'
31 | in
32 | (errors, std)
33 |
34 | let%test "test std build" =
35 | Alcotest.(check bool)
36 | "std build" true
37 | (let errors, std = compile_std () in
38 | pp_sexp (sexp_of_string (errors#show_errors Builtin.std)) ;
39 | pp_sexp (Lang.sexp_of_program std) ;
40 | Result.is_ok (errors#to_result ()) )
41 |
--------------------------------------------------------------------------------
/tonvm.opam:
--------------------------------------------------------------------------------
1 | # This file is generated by dune, edit dune-project instead
2 | opam-version: "2.0"
3 | synopsis: "TON Virtual Machine implementation"
4 | maintainer: ["cmxog@protonmail.com" "dmytro.polunin@gmail.com"]
5 | authors: ["cmxog@protonmail.com" "dmytro.polunin@gmail.com"]
6 | license: "Apache-2.0"
7 | homepage: "https://github.com/tact-lang/tact"
8 | bug-reports: "https://github.com/tact-lang/tact/issues"
9 | depends: [
10 | "ocaml" {>= "4.14.0"}
11 | "base" {>= "0.15.0"}
12 | "bitstring" {>= "4.1.0"}
13 | "ppx_bitstring" {>= "4.1.0"}
14 | "zarith" {>= "1.12"}
15 | "stdint" {>= "0.7.0"}
16 | "ppx_show" {>= "0.2.1"}
17 | "sexplib" {>= "0.15.0"}
18 | "ppx_sexp_conv" {>= "0.15.1"}
19 | "dune" {>= "2.9" & build & >= "3.1.1"}
20 | "ppx_expect" {with-test & >= "0.15.0"}
21 | "odoc" {with-doc}
22 | ]
23 | build: [
24 | ["dune" "subst"] {dev}
25 | [
26 | "dune"
27 | "build"
28 | "-p"
29 | name
30 | "-j"
31 | jobs
32 | "--promote-install-files=false"
33 | "@install"
34 | "@runtest" {with-test}
35 | "@doc" {with-doc}
36 | ]
37 | ["dune" "install" "-p" name "--create-install-files" name]
38 | ]
39 | dev-repo: "git+https://github.com/tact-lang/tact.git"
40 |
--------------------------------------------------------------------------------
/tonvm/bitstr.ml:
--------------------------------------------------------------------------------
1 | (* Workaround for raise Exit in ppx_bitstring + Base *)
2 | exception Exit = Caml.Exit
3 |
4 | type t = Bitstring.t
5 |
6 | let sexp_of_t _ = Sexplib.Sexp.Atom ""
7 |
--------------------------------------------------------------------------------
/tonvm/cp.ml:
--------------------------------------------------------------------------------
1 | type codepage = Codepage of int
2 |
--------------------------------------------------------------------------------
/tonvm/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (libraries zarith stdint base sexplib bitstring)
3 | (package tonvm)
4 | (name tonvm)
5 | (inline_tests)
6 | (preprocess
7 | (pps ppx_sexp_conv ppx_expect ppx_bitstring)))
8 |
--------------------------------------------------------------------------------
/tonvm/instr.ml:
--------------------------------------------------------------------------------
1 | open Base
2 | module Stack = Instr_stack
3 | module Null = Instr_null
4 |
5 | type t = [Stack.t | Null.t] [@@deriving sexp_of, sexp]
6 |
7 | type error = [Stack.error | Null.error]
8 |
9 | let[@warning "-11"] sexp_of_error = function
10 | | #Stack.error as error ->
11 | Stack.sexp_of_error error
12 | | #Null.error as error ->
13 | Null.sexp_of_error error
14 |
15 | let execute vm = function
16 | | #Stack.t as instr ->
17 | Stack.execute vm instr
18 | | #Null.t as instr ->
19 | Null.execute vm instr
20 |
21 | let encode ?(cp = Cp.Codepage 0) = function
22 | | #Stack.t as instr ->
23 | Stack.encode cp instr
24 | | #Null.t as instr ->
25 | Null.encode cp instr
26 |
27 | let decode ?(cp = Cp.Codepage 0) bits =
28 | let decoders = [Stack.decode; Null.decode] in
29 | let init : (t * Bitstring.t, error) Result.t = Ok (`NOP, bits) in
30 | List.fold_until ~init
31 | ~f:(fun _acc decoder ->
32 | match decoder cp bits with
33 | | Ok v ->
34 | Stop (Ok v)
35 | | Error (`UnsupportedBitcode _bits) as err ->
36 | Continue err
37 | | Error _ as err ->
38 | Stop err )
39 | ~finish:(fun acc -> acc)
40 | decoders
41 |
42 | let rec decode_all ?(cp = Cp.Codepage 0) ?(init : t list = []) bits =
43 | match Bitstring.bitstring_length bits with
44 | | 0 ->
45 | Ok (List.rev init, bits)
46 | | _ -> (
47 | match decode ~cp bits with
48 | | Ok (v, bits) ->
49 | decode_all ~cp bits ~init:(v :: init)
50 | | Error _ as err ->
51 | err )
52 |
--------------------------------------------------------------------------------
/tonvm/instr_null.ml:
--------------------------------------------------------------------------------
1 | open Base
2 | open Cp
3 | open Bitstr
4 |
5 | type t = [`NULL | `ISNULL] [@@deriving sexp_of, sexp]
6 |
7 | type error = [`UnsupportedCodepage of Int.t | `UnsupportedBitcode of Bitstr.t]
8 | [@@deriving sexp_of]
9 |
10 | let execute vm = function
11 | | `NULL ->
12 | Vm.push Null vm
13 | | `ISNULL -> (
14 | let value, vm = Vm.pop vm in
15 | match value with
16 | | Null ->
17 | Vm.push Vm.const_true vm
18 | | _ ->
19 | Vm.push Vm.const_false vm )
20 |
21 | let encode cp instr =
22 | match cp with
23 | | Codepage 0 -> (
24 | match instr with
25 | | `NULL ->
26 | let%bitstring bits = {| 0x6D: 8 |} in
27 | Ok bits
28 | | `ISNULL ->
29 | let%bitstring bits = {| 0x6E: 8 |} in
30 | Ok bits )
31 | | Codepage cp ->
32 | Error (`UnsupportedCodepage cp)
33 |
34 | let decode cp bits =
35 | match cp with
36 | | Codepage 0 -> (
37 | match%bitstring bits with
38 | | {| 0x6D : 8 ; rest : -1 :bitstring |} ->
39 | Ok (`NULL, rest)
40 | | {| 0x6E : 8 ; rest : -1 :bitstring |} ->
41 | Ok (`ISNULL, rest)
42 | | {|_|} as bits ->
43 | Error (`UnsupportedBitcode bits) )
44 | | Codepage cp ->
45 | Error (`UnsupportedCodepage cp)
46 |
--------------------------------------------------------------------------------
/tonvm/instr_null_test.ml:
--------------------------------------------------------------------------------
1 | let%expect_test "NULL" =
2 | Tests.(execute "(NULL)" |> print_stack) ;
3 | [%expect {| (Null) |}]
4 |
5 | let%expect_test "NULL encoding" =
6 | Tests.(encode_decode `NULL |> print) ;
7 | [%expect {| (Ok NULL) |}]
8 |
9 | let%expect_test "ISNULL" =
10 | Tests.(execute "(NULL ISNULL)" |> print_stack) ;
11 | [%expect {| ((Integer -1)) |}]
12 |
13 | let%expect_test "negative ISNULL" =
14 | Tests.(execute "(NULL ISNULL ISNULL)" |> print_stack) ;
15 | [%expect {| ((Integer 0)) |}]
16 |
17 | let%expect_test "ISNULL encoding" =
18 | Tests.(encode_decode `ISNULL |> print) ;
19 | [%expect {| (Ok ISNULL) |}]
20 |
--------------------------------------------------------------------------------
/tonvm/instr_stack.ml:
--------------------------------------------------------------------------------
1 | open Base
2 | open Cp
3 | open Bitstr
4 |
5 | type core = [`NOP | `XCHG of int * int | `PUSH of int | `POP of int]
6 | [@@deriving sexp_of, sexp]
7 |
8 | type ext = [`SWAP | `XCHG0 of int | `DUP | `OVER | `DROP | `NIP]
9 | [@@deriving sexp_of, sexp]
10 |
11 | type t = [core | ext] [@@deriving sexp_of, sexp]
12 |
13 | type error =
14 | [ `InvalidInstruction of core
15 | | `UnsupportedBitcode of Bitstr.t
16 | | `UnsupportedCodepage of Int.t ]
17 | [@@deriving sexp_of]
18 |
19 | let rec core_of_ext : ext -> core = function
20 | | `SWAP ->
21 | core_of_ext (`XCHG0 1)
22 | | `XCHG0 i ->
23 | `XCHG (0, i)
24 | | `DUP ->
25 | `PUSH 0
26 | | `OVER ->
27 | `PUSH 1
28 | | `DROP ->
29 | `POP 0
30 | | `NIP ->
31 | `POP 1
32 |
33 | let execute vm =
34 | let execute_core vm = function
35 | | `NOP ->
36 | vm
37 | | `XCHG (i, j) ->
38 | Vm.interchange i j vm
39 | | `PUSH i ->
40 | Vm.push (Vm.at vm i) vm
41 | | `POP i ->
42 | let _, vm = Vm.interchange 0 i vm |> Vm.pop in
43 | vm
44 | in
45 | function
46 | | #ext as instr ->
47 | execute_core vm @@ core_of_ext instr
48 | | #core as instr ->
49 | execute_core vm instr
50 |
51 | let encode cp =
52 | let encode_core instr =
53 | match cp with
54 | | Codepage 0 -> (
55 | match instr with
56 | | `NOP ->
57 | let%bitstring bits = {| 0x00: 8 |} in
58 | Ok bits
59 | | `XCHG (0, i) when i >= 1 && i <= 15 ->
60 | let%bitstring bits = {| 0x0: 4; i : 4 |} in
61 | Ok bits
62 | | `XCHG (i, j) when i >= 1 && j > i && j <= 15 ->
63 | let%bitstring bits = {| 0x10: 8; i : 4; j: 4 |} in
64 | Ok bits
65 | | `XCHG (0, ii) when ii >= 0 && ii <= 255 ->
66 | let%bitstring bits = {| 0x11: 8; ii : 8 |} in
67 | Ok bits
68 | | `PUSH i when i >= 0 && i <= 15 ->
69 | let%bitstring bits = {| 0x2: 4; i : 4 |} in
70 | Ok bits
71 | | `POP i when i >= 0 && i <= 15 ->
72 | let%bitstring bits = {| 0x3: 4; i : 4 |} in
73 | Ok bits
74 | | instr ->
75 | Error (`InvalidInstruction instr) )
76 | | Codepage cp ->
77 | Error (`UnsupportedCodepage cp)
78 | in
79 | function
80 | | #ext as instr ->
81 | encode_core @@ core_of_ext instr
82 | | #core as instr ->
83 | encode_core instr
84 |
85 | let decode cp bits =
86 | match cp with
87 | | Codepage 0 -> (
88 | match%bitstring bits with
89 | | {| 0x00 : 8 ; rest : -1 : bitstring |} ->
90 | Ok (`NOP, rest)
91 | | {| 0x0 : 4 ; i : 4; rest : -1 : bitstring |} ->
92 | Ok (`XCHG (0, i), rest)
93 | | {| 0x10 : 8 ; i : 4; j : 4; rest : -1 : bitstring |} ->
94 | Ok (`XCHG (i, j), rest)
95 | | {| 0x11 : 8 ; ii : 8; rest : -1 : bitstring |} ->
96 | Ok (`XCHG (0, ii), rest)
97 | | {| 0x2 : 4 ; i : 4; rest : -1 : bitstring |} ->
98 | Ok (`PUSH i, rest)
99 | | {| 0x3 : 4 ; i : 4; rest : -1 : bitstring |} ->
100 | Ok (`POP i, rest)
101 | | {|_|} as bits ->
102 | Error (`UnsupportedBitcode bits) )
103 | | Codepage cp ->
104 | Error (`UnsupportedCodepage cp)
105 |
--------------------------------------------------------------------------------
/tonvm/instr_stack_test.ml:
--------------------------------------------------------------------------------
1 | let%expect_test "NOP" =
2 | Tests.(execute "(NOP)" |> print_stack) ;
3 | [%expect {| () |}]
4 |
5 | let%expect_test "NOP encoding" =
6 | Tests.(encode_decode `NOP |> print) ;
7 | [%expect {| (Ok NOP) |}]
8 |
9 | let%expect_test "SWAP" =
10 | Tests.(execute "(NULL DUP ISNULL SWAP)" |> print_stack) ;
11 | [%expect {| (Null (Integer -1)) |}]
12 |
13 | let%expect_test "XCHG0" =
14 | Tests.(execute "(NULL DUP ISNULL (XCHG0 1))" |> print_stack) ;
15 | [%expect {| (Null (Integer -1)) |}]
16 |
17 | let%expect_test "XCHG" =
18 | Tests.(execute "(NULL DUP DUP ISNULL (XCHG (0 2)))" |> print_stack) ;
19 | [%expect {| (Null Null (Integer -1)) |}]
20 |
21 | let%expect_test "XCHG encoding" =
22 | Tests.(encode_decode (`XCHG (0, 1)) |> print) ;
23 | Tests.(encode_decode (`XCHG (1, 2)) |> print) ;
24 | Tests.(encode_decode (`XCHG (0, 100)) |> print) ;
25 | [%expect
26 | {|
27 | (Ok (XCHG (0 1)))
28 | (Ok (XCHG (1 2)))
29 | (Ok (XCHG (0 100))) |}]
30 |
31 | let%expect_test "DUP" =
32 | Tests.(execute "(NULL DUP)" |> print_stack) ;
33 | [%expect {| (Null Null) |}]
34 |
35 | let%expect_test "OVER" =
36 | Tests.(execute "(NULL DUP ISNULL OVER)" |> print_stack) ;
37 | [%expect {| (Null (Integer -1) Null) |}]
38 |
39 | let%expect_test "POP" =
40 | Tests.(execute "(NULL DUP ISNULL (POP 1))" |> print_stack) ;
41 | [%expect {| ((Integer -1)) |}]
42 |
43 | let%expect_test "POP encoding" =
44 | Tests.(encode_decode (`POP 1) |> print) ;
45 | [%expect {|
46 | (Ok (POP 1)) |}]
47 |
48 | let%expect_test "DROP" =
49 | Tests.(execute "(NULL DUP ISNULL DROP)" |> print_stack) ;
50 | [%expect {| (Null) |}]
51 |
52 | let%expect_test "NIP" =
53 | Tests.(execute "(NULL DUP ISNULL NIP)" |> print_stack) ;
54 | [%expect {| ((Integer -1)) |}]
55 |
56 | let%expect_test "PUSH" =
57 | Tests.(execute "(NULL (PUSH 0))" |> print_stack) ;
58 | [%expect {| (Null Null) |}]
59 |
60 | let%expect_test "PUSH encoding" =
61 | Tests.(encode_decode (`PUSH 1) |> print) ;
62 | [%expect {|
63 | (Ok (PUSH 1)) |}]
64 |
--------------------------------------------------------------------------------
/tonvm/tests.ml:
--------------------------------------------------------------------------------
1 | open Base
2 | open Sexplib
3 |
4 | let execute program =
5 | let instrs = List.t_of_sexp Instr.t_of_sexp @@ Sexp.of_string program in
6 | Vm.execute (Vm.make ()) Instr.execute instrs
7 |
8 | let print_stack (vm : Vm.t) =
9 | List.sexp_of_t Vm.sexp_of_value vm.stack
10 | |> Sexplib.Sexp.pp_hum Caml.Format.std_formatter
11 |
12 | let encode_decode ?(cp = Cp.Codepage 0) instr =
13 | Instr.encode ~cp instr
14 | |> Result.bind ~f:(Instr.decode ~cp)
15 | |> Result.map ~f:fst
16 |
17 | let print instr =
18 | let f = Caml.Format.std_formatter in
19 | Sexplib.Sexp.pp_hum f
20 | @@ Result.sexp_of_t Instr.sexp_of_t Instr.sexp_of_error instr ;
21 | Caml.Format.pp_print_newline f ()
22 |
--------------------------------------------------------------------------------
/tonvm/tonvm.ml:
--------------------------------------------------------------------------------
1 | module Instr = Instr
2 | module VM = Vm
3 | module Codepage = Cp
4 |
--------------------------------------------------------------------------------
/tonvm/vm.ml:
--------------------------------------------------------------------------------
1 | open Base
2 |
3 | exception StackUnderflow of int
4 |
5 | type cont = int [@@deriving sexp_of, sexp]
6 |
7 | type value =
8 | | Integer of Zint.t
9 | | Cell
10 | | Tuple
11 | | Null
12 | | Slice
13 | | Builder
14 | | Cont of cont
15 | [@@deriving sexp_of, sexp]
16 |
17 | type codepage = Stdint.int16
18 |
19 | type gas_limits =
20 | { current_gas_limit : int64;
21 | maximal_gas_limit : int64;
22 | remaining_gas : int64;
23 | gas_credit : int64 }
24 |
25 | let default_gas_limits =
26 | { current_gas_limit = 0L;
27 | maximal_gas_limit = 0L;
28 | remaining_gas = 0L;
29 | gas_credit = 0L }
30 |
31 | type t =
32 | { (* Stack *)
33 | stack : value list;
34 | (* Control registers *)
35 | c0 : value;
36 | c1 : value;
37 | c2 : value;
38 | c3 : value;
39 | c4 : value;
40 | c5 : value;
41 | c6 : value;
42 | c7 : value;
43 | c8 : value;
44 | c9 : value;
45 | c10 : value;
46 | c11 : value;
47 | c12 : value;
48 | c13 : value;
49 | c14 : value;
50 | c15 : value;
51 | (* Current continuation *)
52 | cc : cont;
53 | (* Current codepage *)
54 | cp : codepage;
55 | (* Gas limits *)
56 | gas : gas_limits }
57 |
58 | let push value vm = {vm with stack = value :: vm.stack}
59 |
60 | let pop vm =
61 | match vm.stack with
62 | | v :: stack ->
63 | (v, {vm with stack})
64 | | [] ->
65 | raise (StackUnderflow 0)
66 |
67 | let at vm x =
68 | match List.nth vm.stack x with
69 | | Some x' ->
70 | x'
71 | | None ->
72 | raise (StackUnderflow x)
73 |
74 | let interchange x y vm =
75 | let replace pos a l = List.mapi ~f:(fun i x -> if i = pos then a else x) l in
76 | match (List.nth vm.stack x, List.nth vm.stack y) with
77 | | Some x', Some y' ->
78 | {vm with stack = replace x y' vm.stack |> replace y x'}
79 | | None, _ ->
80 | raise (StackUnderflow x)
81 | | _, None ->
82 | raise (StackUnderflow y)
83 |
84 | let const_true = Integer (Z.of_int (-1))
85 |
86 | and const_false = Integer Z.zero
87 |
88 | let make ?(gas = default_gas_limits) () =
89 | { stack = [];
90 | c0 = Null;
91 | c1 = Null;
92 | c2 = Null;
93 | c3 = Null;
94 | c4 = Null;
95 | c5 = Null;
96 | c6 = Null;
97 | c7 = Null;
98 | c8 = Null;
99 | c9 = Null;
100 | c10 = Null;
101 | c11 = Null;
102 | c12 = Null;
103 | c13 = Null;
104 | c14 = Null;
105 | c15 = Null;
106 | cc = 0;
107 | cp = Stdint.Int16.zero;
108 | gas }
109 |
110 | let execute (vm : t) f instrs = List.fold instrs ~init:vm ~f
111 |
--------------------------------------------------------------------------------
/tonvm/zint.ml:
--------------------------------------------------------------------------------
1 | include Z
2 |
3 | let sexp_of_t z = Sexplib.Sexp.of_string @@ Z.to_string z
4 |
5 | let t_of_sexp s = Z.of_string @@ Sexplib.Sexp.to_string s
6 |
--------------------------------------------------------------------------------
5 |
6 |
7 | 
8 |
9 |