From d4d02fd5768061814ba860407a1cf300c1df9d42 Mon Sep 17 00:00:00 2001 From: Robert Virding Date: Sat, 22 Dec 2018 01:23:40 +0100 Subject: [PATCH] First test work commit, don't touch --- LICENSE | 191 ++ include/aeso_heap.hrl | 15 + rebar.config | 13 + src/aeso_abi.erl | 255 +++ src/aeso_ast.erl | 27 + src/aeso_ast_infer_types.erl | 1662 +++++++++++++++++ src/aeso_ast_to_icode.erl | 711 +++++++ src/aeso_builtins.erl | 510 +++++ src/aeso_compiler.erl | 259 +++ src/aeso_constants.erl | 42 + src/aeso_heap.erl | 301 +++ src/aeso_heap.erl~ | 301 +++ src/aeso_icode.erl | 103 + src/aeso_icode.hrl | 68 + src/aeso_icode_to_asm.erl | 979 ++++++++++ src/aeso_memory.erl | 19 + src/aeso_parse_lib.erl | 413 ++++ src/aeso_parse_lib.hrl | 25 + src/aeso_parser.erl | 457 +++++ src/aeso_pretty.erl | 441 +++++ src/aeso_scan.erl | 127 ++ src/aeso_scan_lib.erl | 147 ++ src/aeso_sophia.erl | 30 + src/aeso_syntax.erl | 142 ++ src/aeso_syntax_utils.erl | 94 + src/aeso_utils.erl | 68 + src/aesophia.app.src | 18 + test/aeso_abi_tests.erl | 88 + test/aeso_compiler_tests.erl | 136 ++ test/aeso_eunit_SUITE.erl | 20 + test/aeso_parser_tests.erl | 111 ++ test/aeso_scan_tests.erl | 84 + test/aeso_test_utils.erl | 160 ++ test/contract_tests.erl | 28 + test/contracts/05_greeter.aes | 77 + test/contracts/Makefile | 15 + test/contracts/abort_test.aes | 31 + test/contracts/abort_test_int.aes | 27 + test/contracts/aens.aes | 55 + test/contracts/aeproof.aes | 145 ++ test/contracts/all_syntax.aes | 51 + test/contracts/builtin_bug.aes | 12 + test/contracts/builtin_map_get_bug.aes | 12 + test/contracts/chain.aes | 13 + test/contracts/channel_env.aes | 8 + ...nnel_on_chain_contract_name_resolution.aes | 7 + .../channel_on_chain_contract_oracle.aes | 48 + ...mote_on_chain_contract_name_resolution.aes | 9 + test/contracts/chess.aes | 51 + test/contracts/complex_types.aes | 86 + test/contracts/contract_types.aes | 20 + test/contracts/counter.aes | 9 + test/contracts/dutch_auction.aes | 43 + test/contracts/environment.aes | 69 + test/contracts/erc20_token.aes | 90 + test/contracts/events.aes | 22 + test/contracts/exploits.aes | 6 + test/contracts/factorial.aes | 17 + test/contracts/fundme.aes | 65 + test/contracts/identity.aes | 3 + test/contracts/init_error.aes | 9 + test/contracts/map_of_maps.aes | 36 + test/contracts/maps.aes | 100 + test/contracts/maps_benchmark.aes | 29 + test/contracts/minimal_init.aes | 6 + test/contracts/multi_sig.aes | 123 ++ test/contracts/multiplication_server.aes | 7 + test/contracts/name_clash.aes | 16 + test/contracts/operators.aes | 44 + test/contracts/oracles.aes | 112 ++ test/contracts/oracles_err.aes | 11 + test/contracts/oracles_gas.aes | 24 + test/contracts/oracles_no_vm.aes | 37 + test/contracts/polymorphism_test.aes | 16 + test/contracts/primitive_map.aes | 57 + test/contracts/reason/rte.re | 60 + test/contracts/reason/voting.re | 126 ++ test/contracts/reason/voting_test.re | 42 + test/contracts/remote_call.aes | 27 + test/contracts/remote_gas_test.aes | 20 + test/contracts/remote_oracles.aes | 99 + test/contracts/remote_state.aes | 23 + test/contracts/remote_type_check.aes | 22 + test/contracts/remote_value_on_err.aes | 21 + test/contracts/simple.aes | 3 + test/contracts/simple_storage.aes | 29 + test/contracts/spend_test.aes | 26 + test/contracts/stack.aes | 29 + test/contracts/state_handling.aes | 67 + test/contracts/strings.aes | 4 + test/contracts/test.aes | 101 + test/contracts/type_errors.aes | 42 + test/contracts/upfront_charges.aes | 6 + test/contracts/value_on_err.aes | 7 + test/contracts/variant_types.aes | 29 + test/contracts/voting.aes | 97 + test/contracts/withdrawal.aes | 56 + 97 files changed, 10599 insertions(+) create mode 100644 LICENSE create mode 100644 include/aeso_heap.hrl create mode 100644 rebar.config create mode 100644 src/aeso_abi.erl create mode 100644 src/aeso_ast.erl create mode 100644 src/aeso_ast_infer_types.erl create mode 100644 src/aeso_ast_to_icode.erl create mode 100644 src/aeso_builtins.erl create mode 100644 src/aeso_compiler.erl create mode 100644 src/aeso_constants.erl create mode 100644 src/aeso_heap.erl create mode 100644 src/aeso_heap.erl~ create mode 100644 src/aeso_icode.erl create mode 100644 src/aeso_icode.hrl create mode 100644 src/aeso_icode_to_asm.erl create mode 100644 src/aeso_memory.erl create mode 100644 src/aeso_parse_lib.erl create mode 100644 src/aeso_parse_lib.hrl create mode 100644 src/aeso_parser.erl create mode 100644 src/aeso_pretty.erl create mode 100644 src/aeso_scan.erl create mode 100644 src/aeso_scan_lib.erl create mode 100644 src/aeso_sophia.erl create mode 100644 src/aeso_syntax.erl create mode 100644 src/aeso_syntax_utils.erl create mode 100644 src/aeso_utils.erl create mode 100644 src/aesophia.app.src create mode 100644 test/aeso_abi_tests.erl create mode 100644 test/aeso_compiler_tests.erl create mode 100644 test/aeso_eunit_SUITE.erl create mode 100644 test/aeso_parser_tests.erl create mode 100644 test/aeso_scan_tests.erl create mode 100644 test/aeso_test_utils.erl create mode 100644 test/contract_tests.erl create mode 100644 test/contracts/05_greeter.aes create mode 100644 test/contracts/Makefile create mode 100644 test/contracts/abort_test.aes create mode 100644 test/contracts/abort_test_int.aes create mode 100644 test/contracts/aens.aes create mode 100644 test/contracts/aeproof.aes create mode 100644 test/contracts/all_syntax.aes create mode 100644 test/contracts/builtin_bug.aes create mode 100644 test/contracts/builtin_map_get_bug.aes create mode 100644 test/contracts/chain.aes create mode 100644 test/contracts/channel_env.aes create mode 100644 test/contracts/channel_on_chain_contract_name_resolution.aes create mode 100644 test/contracts/channel_on_chain_contract_oracle.aes create mode 100644 test/contracts/channel_remote_on_chain_contract_name_resolution.aes create mode 100644 test/contracts/chess.aes create mode 100644 test/contracts/complex_types.aes create mode 100644 test/contracts/contract_types.aes create mode 100644 test/contracts/counter.aes create mode 100644 test/contracts/dutch_auction.aes create mode 100644 test/contracts/environment.aes create mode 100644 test/contracts/erc20_token.aes create mode 100644 test/contracts/events.aes create mode 100644 test/contracts/exploits.aes create mode 100644 test/contracts/factorial.aes create mode 100644 test/contracts/fundme.aes create mode 100644 test/contracts/identity.aes create mode 100644 test/contracts/init_error.aes create mode 100644 test/contracts/map_of_maps.aes create mode 100644 test/contracts/maps.aes create mode 100644 test/contracts/maps_benchmark.aes create mode 100644 test/contracts/minimal_init.aes create mode 100644 test/contracts/multi_sig.aes create mode 100644 test/contracts/multiplication_server.aes create mode 100644 test/contracts/name_clash.aes create mode 100644 test/contracts/operators.aes create mode 100644 test/contracts/oracles.aes create mode 100644 test/contracts/oracles_err.aes create mode 100644 test/contracts/oracles_gas.aes create mode 100644 test/contracts/oracles_no_vm.aes create mode 100644 test/contracts/polymorphism_test.aes create mode 100644 test/contracts/primitive_map.aes create mode 100644 test/contracts/reason/rte.re create mode 100644 test/contracts/reason/voting.re create mode 100644 test/contracts/reason/voting_test.re create mode 100644 test/contracts/remote_call.aes create mode 100644 test/contracts/remote_gas_test.aes create mode 100644 test/contracts/remote_oracles.aes create mode 100644 test/contracts/remote_state.aes create mode 100644 test/contracts/remote_type_check.aes create mode 100644 test/contracts/remote_value_on_err.aes create mode 100644 test/contracts/simple.aes create mode 100644 test/contracts/simple_storage.aes create mode 100644 test/contracts/spend_test.aes create mode 100644 test/contracts/stack.aes create mode 100644 test/contracts/state_handling.aes create mode 100644 test/contracts/strings.aes create mode 100644 test/contracts/test.aes create mode 100644 test/contracts/type_errors.aes create mode 100644 test/contracts/upfront_charges.aes create mode 100644 test/contracts/value_on_err.aes create mode 100644 test/contracts/variant_types.aes create mode 100644 test/contracts/voting.aes create mode 100644 test/contracts/withdrawal.aes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..dec7bef --- /dev/null +++ b/LICENSE @@ -0,0 +1,191 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + Copyright 2018, Robert Virding . + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/include/aeso_heap.hrl b/include/aeso_heap.hrl new file mode 100644 index 0000000..a37d97a --- /dev/null +++ b/include/aeso_heap.hrl @@ -0,0 +1,15 @@ + +-record(pmap, {key_t :: aeso_sophia:type(), + val_t :: aeso_sophia:type(), + parent :: none | non_neg_integer(), + size = 0 :: non_neg_integer(), + data :: #{aeso_heap:binary_value() => aeso_heap:binary_value() | tombstone} + | stored}). + +-record(maps, { maps = #{} :: #{ non_neg_integer() => #pmap{} } + , next_id = 0 :: non_neg_integer() }). + +-record(heap, { maps :: #maps{}, + offset :: aeso_heap:offset(), + heap :: binary() | #{non_neg_integer() => non_neg_integer()} }). + diff --git a/rebar.config b/rebar.config new file mode 100644 index 0000000..0a11c7a --- /dev/null +++ b/rebar.config @@ -0,0 +1,13 @@ +%% -*- mode: erlang -*- + +{minimun_otp_vsn, "20.1"}. + +{erl_opts, [debug_info]}. + +{deps, []}. + +{dialyzer, [ + {warnings, [unknown]}, + {plt_apps, all_deps}, + {base_plt_apps, [erts, kernel, stdlib]} + ]}. diff --git a/src/aeso_abi.erl b/src/aeso_abi.erl new file mode 100644 index 0000000..bd7c778 --- /dev/null +++ b/src/aeso_abi.erl @@ -0,0 +1,255 @@ +%%%------------------------------------------------------------------- +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc +%%% Encode and decode data and function calls according to +%%% Sophia-AEVM-ABI. +%%% @end +%%% Created : 25 Jan 2018 +%%% +%%%------------------------------------------------------------------- +-module(aeso_abi). +-define(HASH_SIZE, 32). + +-export([ old_create_calldata/3 + , create_calldata/5 + , check_calldata/2 + , function_type_info/3 + , function_type_hash/3 + , arg_typerep_from_function/2 + , type_hash_from_function_name/2 + , typereps_from_type_hash/2 + , function_name_from_type_hash/2 + , get_function_hash_from_calldata/1 + ]). + +-type hash() :: <<_:256>>. %% 256 = ?HASH_SIZE * 8. +-type function_name() :: binary(). %% String +-type typerep() :: aeso_sophia:type(). +-type function_type_info() :: { FunctionHash :: hash() + , FunctionName :: function_name() + , ArgType :: aeso_sophia:heap() %% binary typerep + , OutType :: aeso_sophia:heap() %% binary typerep + }. +-type type_info() :: [function_type_info()]. + +-ifdef(COMMON_TEST). +-define(TEST_LOG(Format, Data), + try ct:log(Format, Data) + catch + %% Enable setting up node with "test" rebar profile. + error:undef -> ok + end). +-define(DEBUG_LOG(Format, Data), begin lager:debug(Format, Data), ?TEST_LOG(Format, Data) end). +-else. +-define(TEST_LOG(Format, Data), ok). +-define(DEBUG_LOG(Format, Data), lager:debug(Format, Data)). +-endif. + +%%%=================================================================== +%%% API +%%%=================================================================== + +%%%=================================================================== +%%% Handle calldata + +create_calldata(Contract, FunName, Args, ArgTypes, RetType) -> + case get_type_info_and_hash(Contract, FunName) of + {ok, TypeInfo, TypeHashInt} -> + Data = aeso_heap:to_binary({TypeHashInt, list_to_tuple(Args)}), + case check_calldata(Data, TypeInfo) of + {ok, CallDataType, OutType} -> + case check_given_type(FunName, ArgTypes, RetType, CallDataType, OutType) of + ok -> + {ok, Data, CallDataType, OutType}; + {error, _} = Err -> + Err + end; + {error,_What} = Err -> Err + end; + {error, _} = Err -> Err + end. + +get_type_info_and_hash(#{type_info := TypeInfo}, FunName) -> + FunBin = list_to_binary(FunName), + case type_hash_from_function_name(FunBin, TypeInfo) of + {ok, <>} -> {ok, TypeInfo, TypeHashInt}; + {ok, _} -> {error, bad_type_hash}; + {error, _} = Err -> Err + end. + +%% Check that the given type matches the type from the metadata. +check_given_type(FunName, GivenArgs, GivenRet, CalldataType, ExpectRet) -> + {tuple, [word, {tuple, ExpectArgs}]} = CalldataType, + ReturnOk = if FunName == "init" -> true; + GivenRet == any -> true; + true -> GivenRet == ExpectRet + end, + ArgsOk = ExpectArgs == GivenArgs, + case ReturnOk andalso ArgsOk of + true -> ok; + false when FunName == "init" -> + {error, {init_args_mismatch, + {given, GivenArgs}, + {expected, ExpectArgs}}}; + false -> + {error, {call_type_mismatch, + {given, GivenArgs, '=>', GivenRet}, + {expected, ExpectArgs, '=>', ExpectRet}}} + end. + +-spec check_calldata(aeso_sophia:heap(), type_info()) -> + {'ok', typerep()} | {'error', atom()}. +check_calldata(CallData, TypeInfo) -> + %% The first element of the CallData should be the function name + case get_function_hash_from_calldata(CallData) of + {ok, Hash} -> + case typereps_from_type_hash(Hash, TypeInfo) of + {ok, ArgType, OutType} -> + try aeso_heap:from_binary({tuple, [word, ArgType]}, CallData) of + {ok, _Something} -> + {ok, {tuple, [word, ArgType]}, OutType}; + {error, _} -> + {error, bad_call_data} + catch + _T:_E -> + ?TEST_LOG("Error parsing call data: ~p", [{_T, _E}]), + {error, bad_call_data} + end; + {error, _} -> + ?TEST_LOG("Unknown function hash ~p", [Hash]), + {error, unknown_function} + end; + {error, _What} -> + ?TEST_LOG("Bad call data ~p", [_What]), + {error, bad_call_data} + end. + +-spec get_function_hash_from_calldata(CallData::binary()) -> + {ok, binary()} | {error, term()}. +get_function_hash_from_calldata(CallData) -> + case aeso_heap:from_binary({tuple, [word]}, CallData) of + {ok, {HashInt}} -> {ok, <>}; + {error, _} = Error -> Error + end. + +%%%=================================================================== +%%% Handle type info from contract meta data + +-spec function_type_info(function_name(), [typerep()], typerep()) -> + function_type_info(). +function_type_info(Name, Args, OutType) -> + ArgType = {tuple, [T || {_, T} <- Args]}, + { function_type_hash(Name, ArgType, OutType) + , Name + , aeso_heap:to_binary(ArgType) + , aeso_heap:to_binary(OutType) + }. + +-spec function_type_hash(function_name(), typerep(), typerep()) -> hash(). +function_type_hash(Name, ArgType, OutType) when is_binary(Name) -> + Bin = iolist_to_binary([ Name + , aeso_heap:to_binary(ArgType) + , aeso_heap:to_binary(OutType) + ]), + %% Calculate a 256 bit digest BLAKE2b hash value of a binary + {ok, Hash} = enacl:generichash(?HASH_SIZE, Bin), + Hash. + +-spec arg_typerep_from_function(function_name(), type_info()) -> + {'ok', typerep()} | {'error', 'bad_type_data' | 'unknown_function'}. +arg_typerep_from_function(Function, TypeInfo) -> + case lists:keyfind(Function, 2, TypeInfo) of + {_TypeHash, Function, ArgTypeBin,_OutTypeBin} -> + case aeso_heap:from_binary(typerep, ArgTypeBin) of + {ok, ArgType} -> {ok, ArgType}; + {error,_} -> {error, bad_type_data} + end; + false -> + {error, unknown_function} + end. + +-spec typereps_from_type_hash(hash(), type_info()) -> + {'ok', typerep()} | {'error', 'bad_type_data' | 'unknown_function'}. +typereps_from_type_hash(TypeHash, TypeInfo) -> + case lists:keyfind(TypeHash, 1, TypeInfo) of + {TypeHash,_Function, ArgTypeBin, OutTypeBin} -> + case {aeso_heap:from_binary(typerep, ArgTypeBin), + aeso_heap:from_binary(typerep, OutTypeBin)} of + {{ok, ArgType}, {ok, OutType}} -> {ok, ArgType, OutType}; + {_, _} -> {error, bad_type_data} + end; + false -> + {error, unknown_function} + end. + +-spec function_name_from_type_hash(hash(), type_info()) -> + {'ok', function_name()} + | {'error', 'unknown_function'}. +function_name_from_type_hash(TypeHash, TypeInfo) -> + case lists:keyfind(TypeHash, 1, TypeInfo) of + {TypeHash, Function,_ArgTypeBin,_OutTypeBin} -> + {ok, Function}; + false -> + {error, unknown_function} + end. + +-spec type_hash_from_function_name(function_name(), type_info()) -> + {'ok', hash()} + | {'error', 'unknown_function'}. +type_hash_from_function_name(Name, TypeInfo) -> + case lists:keyfind(Name, 2, TypeInfo) of + {TypeHash, Name,_ArgTypeBin,_OutTypeBin} -> + {ok, TypeHash}; + false -> + {error, unknown_function} + end. + +%% -- Old calldata creation. Kept for backwards compatibility. --------------- + +old_create_calldata(Contract, Function, Argument) when is_map(Contract) -> + case aeso_constants:string(Argument) of + {ok, {tuple, _, _} = Tuple} -> + old_encode_call(Contract, Function, Tuple); + {ok, {unit, _} = Tuple} -> + old_encode_call(Contract, Function, Tuple); + {ok, ParsedArgument} -> + %% The Sophia compiler does not parse a singleton tuple (42) as a tuple, + %% Wrap it in a tuple. + old_encode_call(Contract, Function, {tuple, [], [ParsedArgument]}); + {error, _} -> + {error, argument_syntax_error} + end. + +%% Call takes one arument. +%% Use a tuple to pass multiple arguments. +old_encode_call(Contract, Function, ArgumentAst) -> + Argument = old_ast_to_erlang(ArgumentAst), + case get_type_info_and_hash(Contract, Function) of + {ok, TypeInfo, TypeHashInt} -> + Data = aeso_heap:to_binary({TypeHashInt, Argument}), + case check_calldata(Data, TypeInfo) of + {ok, CallDataType, OutType} -> + {ok, Data, CallDataType, OutType}; + {error, _} = Err -> + Err + end; + {error, _} = Err -> Err + end. + +old_ast_to_erlang({int, _, N}) -> N; +old_ast_to_erlang({hash, _, <>}) -> N; +old_ast_to_erlang({hash, _, <>}) -> {Hi, Lo}; %% signature +old_ast_to_erlang({bool, _, true}) -> 1; +old_ast_to_erlang({bool, _, false}) -> 0; +old_ast_to_erlang({string, _, Bin}) -> Bin; +old_ast_to_erlang({unit, _}) -> {}; +old_ast_to_erlang({con, _, "None"}) -> none; +old_ast_to_erlang({app, _, {con, _, "Some"}, [A]}) -> {some, old_ast_to_erlang(A)}; +old_ast_to_erlang({tuple, _, Elems}) -> + list_to_tuple(lists:map(fun old_ast_to_erlang/1, Elems)); +old_ast_to_erlang({list, _, Elems}) -> + lists:map(fun old_ast_to_erlang/1, Elems); +old_ast_to_erlang({map, _, Elems}) -> + maps:from_list([ {old_ast_to_erlang(element(1, Elem)), old_ast_to_erlang(element(2, Elem))} + || Elem <- Elems ]). + diff --git a/src/aeso_ast.erl b/src/aeso_ast.erl new file mode 100644 index 0000000..ee25e15 --- /dev/null +++ b/src/aeso_ast.erl @@ -0,0 +1,27 @@ +-module(aeso_ast). + +-export([int/2, + line/1, + pp/1, + pp_typed/1, + symbol/2, + symbol_name/1 + ]). + + +symbol(Line, Chars) -> {symbol, Line, Chars}. +int(Line, Int) -> {'Int', Line, Int}. + +line({symbol, Line, _}) -> Line. + +symbol_name({symbol, _, Name}) -> Name. + +pp(Ast) -> + %% TODO: Actually do *Pretty* printing. + io:format("~p~n", [Ast]). + +pp_typed(TypedAst) -> + String = prettypr:format(aeso_pretty:decls(TypedAst, [show_generated])), + %%io:format("Typed tree:\n~p\n",[TypedAst]), + io:format("Type info:\n~s\n",[String]). + diff --git a/src/aeso_ast_infer_types.erl b/src/aeso_ast_infer_types.erl new file mode 100644 index 0000000..e78dc83 --- /dev/null +++ b/src/aeso_ast_infer_types.erl @@ -0,0 +1,1662 @@ +%%%------------------------------------------------------------------- +%%% @copyright (C) 2018, Aeternity Anstalt +%%% @doc +%%% Type checker for Sophia. +%%% @end +%%%------------------------------------------------------------------- + +%%% All state is kept in a set of ETS tables. These are NOT named +%%% tables and the table ids are kept in process dictionary in a map +%%% under the key 'aeso_ast_infer_types'. This allows multiple +%%% instances of the compiler to be run in parallel. + +-module(aeso_ast_infer_types). + +-export([infer/1, infer/2, infer_constant/1]). + +-type utype() :: {fun_t, aeso_syntax:ann(), named_args_t(), [utype()], utype()} + | {app_t, aeso_syntax:ann(), utype(), [utype()]} + | {tuple_t, aeso_syntax:ann(), [utype()]} + | aeso_syntax:id() | aeso_syntax:qid() + | aeso_syntax:con() | aeso_syntax:qcon() %% contracts + | aeso_syntax:tvar() + | uvar(). + +-type uvar() :: {uvar, aeso_syntax:ann(), reference()}. + +-type named_args_t() :: uvar() | [{named_arg_t, aeso_syntax:ann(), aeso_syntax:id(), utype(), aeso_syntax:expr()}]. + +-type type_id() :: aeso_syntax:id() | aeso_syntax:qid() | aeso_syntax:con() | aeso_syntax:qcon(). + +-define(is_type_id(T), element(1, T) =:= id orelse + element(1, T) =:= qid orelse + element(1, T) =:= con orelse + element(1, T) =:= qcon). + +-type why_record() :: aeso_syntax:field(aeso_syntax:expr()) + | {proj, aeso_syntax:ann(), aeso_syntax:expr(), aeso_syntax:id()}. + +-record(named_argument_constraint, + {args :: named_args_t(), + name :: aeso_syntax:id(), + type :: utype()}). + +-type named_argument_constraint() :: #named_argument_constraint{}. + +-record(field_constraint, + { record_t :: utype() + , field :: aeso_syntax:id() + , field_t :: utype() + , kind :: project | create | update %% Projection constraints can match contract + , context :: why_record() }). %% types, but field constraints only record types. + +-type field_constraint() :: #field_constraint{}. + +-record(field_info, + { field_t :: utype() + , record_t :: utype() + , kind :: contract | record }). + +-type field_info() :: #field_info{}. + +-define(PRINT_TYPES(Fmt, Args), + when_option(pp_types, fun () -> io:format(Fmt, Args) end)). + +%% Environment containing language primitives +-spec global_env() -> [{string(), aeso_syntax:type()}]. +global_env() -> + Ann = [{origin, system}], + Int = {id, Ann, "int"}, + Bool = {id, Ann, "bool"}, + String = {id, Ann, "string"}, + Address = {id, Ann, "address"}, + Event = {id, Ann, "event"}, + State = {id, Ann, "state"}, + Hash = {id, Ann, "hash"}, + Oracle = fun(Q, R) -> {app_t, Ann, {id, Ann, "oracle"}, [Q, R]} end, + Query = fun(Q, R) -> {app_t, Ann, {id, Ann, "oracle_query"}, [Q, R]} end, + Unit = {tuple_t, Ann, []}, + List = fun(T) -> {app_t, Ann, {id, Ann, "list"}, [T]} end, + Option = fun(T) -> {app_t, Ann, {id, Ann, "option"}, [T]} end, + Map = fun(A, B) -> {app_t, Ann, {id, Ann, "map"}, [A, B]} end, + Pair = fun(A, B) -> {tuple_t, Ann, [A, B]} end, + Fun = fun(Ts, T) -> {type_sig, Ann, [], Ts, T} end, + Fun1 = fun(S, T) -> Fun([S], T) end, + TVar = fun(X) -> {tvar, Ann, "'" ++ X} end, + SignId = {id, Ann, "signature"}, + SignDef = {tuple, Ann, [{int, Ann, 0}, {int, Ann, 0}]}, + Signature = {named_arg_t, Ann, SignId, SignId, {typed, Ann, SignDef, SignId}}, + SignFun = fun(Ts, T) -> {type_sig, Ann, [Signature], Ts, T} end, + TTL = {qid, Ann, ["Chain", "ttl"]}, + Fee = Int, + [A, Q, R, K, V] = lists:map(TVar, ["a", "q", "r", "k", "v"]), + %% Option constructors + [{"None", Option(A)}, + {"Some", Fun1(A, Option(A))}, + %% TTL constructors + {"RelativeTTL", Fun1(Int, TTL)}, + {"FixedTTL", Fun1(Int, TTL)}, + %% Spend transaction. + {["Chain","spend"], Fun([Address, Int], Unit)}, + %% Environment variables + %% {["Contract", "owner"], Int}, %% Not in EVM? + {["Contract", "address"], Address}, + {["Contract", "balance"], Int}, + {["Call", "origin"], Address}, + {["Call", "caller"], Address}, + {["Call", "value"], Int}, + {["Call", "gas_price"], Int}, + {["Call", "gas_left"], Fun([], Int)}, + {["Chain", "balance"], Fun1(Address, Int)}, + {["Chain", "block_hash"], Fun1(Int, Int)}, + {["Chain", "coinbase"], Address}, + {["Chain", "timestamp"], Int}, + {["Chain", "block_height"], Int}, + {["Chain", "difficulty"], Int}, + {["Chain", "gas_limit"], Int}, + {["Chain", "event"], Fun1(Event, Unit)}, + %% State + {"state", State}, + {"put", Fun1(State, Unit)}, + %% Abort + {"abort", Fun1(String, A)}, + %% Oracles + {["Oracle", "register"], SignFun([Address, Fee, TTL], Oracle(Q, R))}, + {["Oracle", "query_fee"], Fun([Oracle(Q, R)], Fee)}, + {["Oracle", "query"], Fun([Oracle(Q, R), Q, Fee, TTL, TTL], Query(Q, R))}, + {["Oracle", "get_question"], Fun([Oracle(Q, R), Query(Q, R)], Q)}, + {["Oracle", "respond"], SignFun([Oracle(Q, R), Query(Q, R), R], Unit)}, + {["Oracle", "extend"], SignFun([Oracle(Q, R), TTL], Unit)}, + {["Oracle", "get_answer"], Fun([Oracle(Q, R), Query(Q, R)], option_t(Ann, R))}, + %% Name service + {["AENS", "resolve"], Fun([String, String], option_t(Ann, A))}, + {["AENS", "preclaim"], SignFun([Address, Hash], Unit)}, + {["AENS", "claim"], SignFun([Address, String, Int], Unit)}, + {["AENS", "transfer"], SignFun([Address, Address, Hash], Unit)}, + {["AENS", "revoke"], SignFun([Address, Hash], Unit)}, + %% Maps + {["Map", "from_list"], Fun1(List(Pair(K, V)), Map(K, V))}, + {["Map", "to_list"], Fun1(Map(K, V), List(Pair(K, V)))}, + {["Map", "lookup"], Fun([K, Map(K, V)], Option(V))}, + {["Map", "lookup_default"], Fun([K, Map(K, V), V], V)}, + {["Map", "delete"], Fun([K, Map(K, V)], Map(K, V))}, + {["Map", "member"], Fun([K, Map(K, V)], Bool)}, + {["Map", "size"], Fun1(Map(K, V), Int)}, + %% Strings + {["String", "length"], Fun1(String, Int)}, + {["String", "concat"], Fun([String, String], String)}, + {["String", "sha3"], Fun1(String, Int)}, + %% Conversion + {["Int", "to_str"], Fun1(Int, String)}, + {["Address", "to_str"], Fun1(Address, String)} + ]. + +global_type_env() -> + _As = [{origin, system}], + []. + +option_t(As, T) -> {app_t, As, {id, As, "option"}, [T]}. +map_t(As, K, V) -> {app_t, As, {id, As, "map"}, [K, V]}. + +-spec infer(aeso_syntax:ast()) -> aeso_syntax:ast(). +infer(Contracts) -> + infer(Contracts, []). + +-type option() :: permissive_address_literals. + +-spec infer(aeso_syntax:ast(), list(option())) -> aeso_syntax:ast(). +infer(Contracts, Options) -> + ets_init(), %Init the ETS table state + try + TypeEnv = + case proplists:get_value(permissive_address_literals, Options, false) of + false -> global_type_env(); + true -> + %% Treat oracle and query ids as address to allow address literals for these + Tag = fun(Tag, Vals) -> list_to_tuple([Tag, [{origin, system}] | Vals]) end, + Alias = fun(Name, Arity) -> + Tag(type_def, [Tag(id, [Name]), + lists:duplicate(Arity, Tag(tvar, "_")), + {alias_t, Tag(id, ["address"])}]) + end, + [Alias("oracle", 2), Alias("oracle_query", 2)] + end, + create_options(Options), + ets_new(type_vars, [set]), + infer1(TypeEnv, Contracts) + after + clean_up_ets() + end. + +infer1(TypeEnv, [Contract = {contract, Attribs, ConName, Code}|Rest]) -> + %% do type inference on each contract independently. + Contract1 = {contract, Attribs, ConName, infer_contract_top(TypeEnv, Code)}, + TypeEnv1 = [Contract | TypeEnv], + [Contract1 | infer1(TypeEnv1, Rest)]; +infer1(_, []) -> + []. + +infer_contract_top(TypeEnv, Defs0) -> + Defs = desugar(Defs0), + create_type_defs(TypeEnv ++ Defs), + C = unfold_record_types(infer_contract(global_env(), Defs)), + destroy_type_defs(), + C. + +infer_constant({letval, Attrs,_Pattern, Type, E}) -> + ets_init(), %Init the ETS table state + create_type_defs([]), + {typed, _, _, PatType} = + infer_expr(global_env(), {typed, Attrs, E, arg_type(Type)}), + T = instantiate(PatType), + destroy_type_defs(), + T. + +%% infer_contract takes a proplist mapping global names to types, and +%% a list of definitions. +infer_contract(Env, Defs) -> + Kind = fun({type_def, _, _, _, _}) -> type; + ({letfun, _, _, _, _, _}) -> function; + ({fun_decl, _, _, _}) -> prototype + end, + Get = fun(K) -> [ Def || Def <- Defs, Kind(Def) == K ] end, + {Env1, TypeDefs} = check_typedefs(Env, Get(type)), + ProtoSigs = [ check_fundecl(Env1, Decl) || Decl <- Get(prototype) ], + Env2 = ProtoSigs ++ Env1, + Functions = Get(function), + check_name_clashes(Env2, Functions), + FunMap = maps:from_list([ {Fun, Def} || Def = {letfun, _, {id, _, Fun}, _, _, _} <- Functions ]), + check_reserved_entrypoints(FunMap), + DepGraph = maps:map(fun(_, Def) -> aeso_syntax_utils:used_ids(Def) end, FunMap), + SCCs = aeso_utils:scc(DepGraph), + %% io:format("Dependency sorted functions:\n ~p\n", [SCCs]), + create_type_errors(), + FinalEnv = TypeDefs ++ check_sccs(Env2, FunMap, SCCs, []), + destroy_and_report_type_errors(), + FinalEnv. + +check_name_clashes(Env, Funs) -> + create_type_errors(), + Name = fun({fun_decl, Ann, {id, _, X}, _}) -> [{X, Ann}]; + ({letfun, Ann, {id, _, X}, _, _, _}) -> [{X, Ann}]; + ({type_def, _, _, _, _}) -> []; + ({X, Type}) -> [{X, aeso_syntax:get_ann(Type)}] + end, + All = lists:flatmap(Name, Env ++ Funs), + Names = [ X || {X, _} <- All ], + Duplicates = lists:usort(Names -- lists:usort(Names)), + [ type_error({duplicate_definition, X, [ Ann || {Y, Ann} <- All, X == Y ]}) + || X <- Duplicates ], + destroy_and_report_type_errors(), + ok. + +check_typedefs(Env, Defs) -> + create_type_errors(), + GetName = fun({type_def, _, {id, _, Name}, _, _}) -> Name end, + TypeMap = maps:from_list([ {GetName(Def), Def} || Def <- Defs ]), + DepGraph = maps:map(fun(_, Def) -> aeso_syntax_utils:used_types(Def) end, TypeMap), + SCCs = aeso_utils:scc(DepGraph), + %% io:format("Dependency sorted types:\n ~p\n", [SCCs]), + Env1 = check_typedef_sccs(Env, TypeMap, SCCs), + destroy_and_report_type_errors(), + SCCNames = fun({cyclic, Xs}) -> Xs; ({acyclic, X}) -> [X] end, + {Env1, [ Def || SCC <- SCCs, Name <- SCCNames(SCC), + Def <- [maps:get(Name, TypeMap, undefined)], Def /= undefined ]}. + +check_typedef_sccs(Env, _TypeMap, []) -> Env; +check_typedef_sccs(Env, TypeMap, [{acyclic, Name} | SCCs]) -> + case maps:get(Name, TypeMap, undefined) of + undefined -> check_typedef_sccs(Env, TypeMap, SCCs); %% Builtin type + {type_def, Ann, D, Xs, Def} -> + case Def of + {alias_t, _} -> check_typedef_sccs(Env, TypeMap, SCCs); %% TODO: check these + {record_t, _} -> check_typedef_sccs(Env, TypeMap, SCCs); %% and these + {variant_t, Cons} -> + Target = {app_t, Ann, D, Xs}, + ConType = fun([]) -> Target; (Args) -> {type_sig, Ann, [], Args, Target} end, + ConTypes = [ begin + {constr_t, _, {con, _, Con}, Args} = ConDef, + {Con, ConType(Args)} + end || ConDef <- Cons ], + check_repeated_constructors([ {Con, ConType(Args)} || {constr_t, _, Con, Args} <- Cons ]), + [ check_constructor_overlap(Env, Con, Target) || {constr_t, _, Con, _} <- Cons ], + [ check_event(Cons) || Name == "event" ], + check_typedef_sccs(ConTypes ++ Env, TypeMap, SCCs) + end + end; +check_typedef_sccs(Env, TypeMap, [{cyclic, Names} | SCCs]) -> + Id = fun(X) -> {type_def, _, D, _, _} = maps:get(X, TypeMap), D end, + type_error({recursive_types_not_implemented, lists:map(Id, Names)}), + check_typedef_sccs(Env, TypeMap, SCCs). + +check_event(Cons) -> + [ check_event(Name, Types) || {constr_t, _, {con, _, Name}, Types} <- Cons ]. + +%% Initially we limit the type of an event, it can have 0-3 topics/indexed "words" +%% and 0-1 strings as payload. +check_event(Name, Types) -> + IsIndexed = fun(T) -> aeso_syntax:get_ann(indexed, T, false) end, + Indexed = [ T || T <- Types, IsIndexed(T) ], + NonIndexed = Types -- Indexed, + %% TODO: Is is possible to check also the types of arguments in a sensible way? + [ type_error({event_0_to_3_indexed_values, Name}) || length(Indexed) > 3 ], + [ type_error({event_0_to_1_string_values, Name}) || length(NonIndexed) > 1 ]. + +check_constructor_overlap(Env, Con = {con, _, Name}, NewType) -> + case proplists:get_value(Name, Env) of + undefined -> ok; + Type -> + OldType = case Type of {type_sig, _, _, _, T} -> T; + _ -> Type end, + OldCon = {con, aeso_syntax:get_ann(OldType), Name}, %% TODO: we don't have the location of the old constructor here + type_error({repeated_constructor, [{OldCon, OldType}, {Con, NewType}]}) + end. + +check_repeated_constructors(Cons) -> + Names = [ Name || {{con, _, Name}, _} <- Cons ], + Duplicated = lists:usort(Names -- lists:usort(Names)), + Fail = fun(Name) -> + type_error({repeated_constructor, [ CT || CT = {{con, _, C}, _} <- Cons, C == Name ]}) + end, + [ Fail(Dup) || Dup <- Duplicated ], + ok. + +check_sccs(_, _, [], Acc) -> lists:reverse(Acc); +check_sccs(Env, Funs, [{acyclic, X} | SCCs], Acc) -> + case maps:get(X, Funs, undefined) of + undefined -> %% Previously defined function + check_sccs(Env, Funs, SCCs, Acc); + Def -> + {TypeSig, Def1} = infer_nonrec(Env, Def), + Env1 = [TypeSig | Env], + check_sccs(Env1, Funs, SCCs, [Def1 | Acc]) + end; +check_sccs(Env, Funs, [{cyclic, Xs} | SCCs], Acc) -> + Defs = [ maps:get(X, Funs) || X <- Xs ], + {TypeSigs, {letrec, _, Defs1}} = infer_letrec(Env, {letrec, [], Defs}), + Env1 = TypeSigs ++ Env, + check_sccs(Env1, Funs, SCCs, Defs1 ++ Acc). + +check_reserved_entrypoints(Funs) -> + Reserved = ["address"], + create_type_errors(), + [ type_error({reserved_entrypoint, Name, Def}) + || {Name, Def} <- maps:to_list(Funs), lists:member(Name, Reserved) ], + destroy_and_report_type_errors(). + +check_fundecl(_Env, {fun_decl, Attrib, {id, _NameAttrib, Name}, {fun_t, _, Named, Args, Ret}}) -> + {Name, {type_sig, Attrib, Named, Args, Ret}}; %% TODO: actually check that the type makes sense! +check_fundecl(_, {fun_decl, _Attrib, {id, _, Name}, Type}) -> + error({fundecl_must_have_funtype, Name, Type}). + +infer_nonrec(Env, LetFun) -> + create_constraints(), + NewLetFun = infer_letfun(Env, LetFun), + solve_constraints(), + destroy_and_report_unsolved_constraints(), + Result = {TypeSig, _} = instantiate(NewLetFun), + print_typesig(TypeSig), + Result. + +typesig_to_fun_t({type_sig, Ann, Named, Args, Res}) -> {fun_t, Ann, Named, Args, Res}. + +infer_letrec(Env, {letrec, Attrs, Defs}) -> + create_constraints(), + Env1 = [{Name, fresh_uvar(A)} + || {letfun, _, {id, A, Name}, _, _, _} <- Defs], + ExtendEnv = Env1 ++ Env, + Inferred = + [ begin + Res = {{Name, TypeSig}, _} = infer_letfun(ExtendEnv, LF), + Got = proplists:get_value(Name, Env1), + Expect = typesig_to_fun_t(TypeSig), + unify(Got, Expect, {check_typesig, Name, Got, Expect}), + solve_field_constraints(), + ?PRINT_TYPES("Checked ~s : ~s\n", + [Name, pp(dereference_deep(Got))]), + Res + end || LF <- Defs ], + destroy_and_report_unsolved_constraints(), + TypeSigs = instantiate([Sig || {Sig, _} <- Inferred]), + NewDefs = instantiate([D || {_, D} <- Inferred]), + [print_typesig(S) || S <- TypeSigs], + {TypeSigs, {letrec, Attrs, NewDefs}}. + +infer_letfun(Env, {letfun, Attrib, {id, NameAttrib, Name}, Args, What, Body}) -> + ArgTypes = [{ArgName, arg_type(T)} || {arg, _, {id, _, ArgName}, T} <- Args], + ExpectedType = arg_type(What), + NewBody={typed, _, _, ResultType} = check_expr(ArgTypes ++ Env, Body, ExpectedType), + NewArgs = [{arg, A1, {id, A2, ArgName}, T} + || {{ArgName, T}, {arg, A1, {id, A2, ArgName}, _}} <- lists:zip(ArgTypes, Args)], + NamedArgs = [], + TypeSig = {type_sig, Attrib, NamedArgs, [T || {arg, _, _, T} <- NewArgs], ResultType}, + {{Name, TypeSig}, + {letfun, Attrib, {id, NameAttrib, Name}, NewArgs, ResultType, NewBody}}. + +print_typesig({Name, TypeSig}) -> + ?PRINT_TYPES("Inferred ~s : ~s\n", [Name, pp(TypeSig)]). + +arg_type({id, Attrs, "_"}) -> + fresh_uvar(Attrs); +arg_type({app_t, Attrs, Name, Args}) -> + {app_t, Attrs, Name, [arg_type(T) || T <- Args]}; +arg_type(T) -> + T. + +lookup_name(Env, As, Name) -> + lookup_name(Env, As, Name, []). + +lookup_name(Env, As, Name, Options) -> + case proplists:get_value(Name, Env) of + undefined -> + Id = case Name of + [C | _] when is_integer(C) -> {id, As, Name}; + [X | _] when is_list(X) -> {qid, As, Name} + end, + type_error({unbound_variable, Id}), + fresh_uvar(As); + {type_sig, _, _, _, _} = Type -> + freshen_type(typesig_to_fun_t(Type)); + Type -> + case proplists:get_value(freshen, Options, false) of + true -> freshen_type(Type); + false -> Type + end + end. + +check_expr(Env, Expr, Type) -> + E = {typed, _, _, Type1} = infer_expr(Env, Expr), + unify(Type1, Type, {check_expr, Expr, Type1, Type}), + E. + +infer_expr(_Env, Body={bool, As, _}) -> + {typed, As, Body, {id, As, "bool"}}; +infer_expr(_Env, Body={int, As, _}) -> + {typed, As, Body, {id, As, "int"}}; +infer_expr(_Env, Body={string, As, _}) -> + {typed, As, Body, {id, As, "string"}}; +infer_expr(_Env, Body={hash, As, Hash}) -> + case byte_size(Hash) of + 32 -> {typed, As, Body, {id, As, "address"}}; + 64 -> {typed, As, Body, {id, As, "signature"}} + end; +infer_expr(_Env, Body={id, As, "_"}) -> + {typed, As, Body, fresh_uvar(As)}; +infer_expr(Env, Body={id, As, Name}) -> + Type = lookup_name(Env, As, Name), + {typed, As, Body, Type}; +infer_expr(Env, Body={qid, As, Name}) -> + Type = lookup_name(Env, As, Name), + {typed, As, Body, Type}; +infer_expr(Env, Body={con, As, Name}) -> + Type = lookup_name(Env, As, Name, [freshen]), + {typed, As, Body, Type}; +infer_expr(Env, {unit, As}) -> + infer_expr(Env, {tuple, As, []}); +infer_expr(Env, {tuple, As, Cpts}) -> + NewCpts = [infer_expr(Env, C) || C <- Cpts], + CptTypes = [T || {typed, _, _, T} <- NewCpts], + {typed, As, {tuple, As, NewCpts}, {tuple_t, As, CptTypes}}; +infer_expr(Env, {list, As, Elems}) -> + ElemType = fresh_uvar(As), + NewElems = [check_expr(Env, X, ElemType) || X <- Elems], + {typed, As, {list, As, NewElems}, {app_t, As, {id, As, "list"}, [ElemType]}}; +infer_expr(Env, {typed, As, Body, Type}) -> + {typed, _, NewBody, NewType} = check_expr(Env, Body, Type), + {typed, As, NewBody, NewType}; +infer_expr(Env, {app, Ann, Fun, Args0}) -> + %% TODO: fix parser to give proper annotation for normal applications! + FunAnn = aeso_syntax:get_ann(Fun), + NamedArgs = [ Arg || Arg = {named_arg, _, _, _} <- Args0 ], + Args = Args0 -- NamedArgs, + case aeso_syntax:get_ann(format, Ann) of + infix -> + infer_op(Env, Ann, Fun, Args, fun infer_infix/1); + prefix -> + infer_op(Env, Ann, Fun, Args, fun infer_prefix/1); + _ -> + NamedArgsVar = fresh_uvar(FunAnn), + NamedArgs1 = [ infer_named_arg(Env, NamedArgsVar, Arg) || Arg <- NamedArgs ], + %% TODO: named args constraints + NewFun={typed, _, _, FunType} = infer_expr(Env, Fun), + NewArgs = [infer_expr(Env, A) || A <- Args], + ArgTypes = [T || {typed, _, _, T} <- NewArgs], + ResultType = fresh_uvar(FunAnn), + unify(FunType, {fun_t, [], NamedArgsVar, ArgTypes, ResultType}, {infer_app, Fun, Args, FunType, ArgTypes}), + {typed, FunAnn, {app, Ann, NewFun, NamedArgs1 ++ NewArgs}, dereference(ResultType)} + end; +infer_expr(Env, {'if', Attrs, Cond, Then, Else}) -> + NewCond = check_expr(Env, Cond, {id, Attrs, "bool"}), + NewThen = {typed, _, _, ThenType} = infer_expr(Env, Then), + NewElse = {typed, _, _, ElseType} = infer_expr(Env, Else), + unify(ThenType, ElseType, {if_branches, Then, ThenType, Else, ElseType}), + {typed, Attrs, {'if', Attrs, NewCond, NewThen, NewElse}, ThenType}; +infer_expr(Env, {switch, Attrs, Expr, Cases}) -> + NewExpr = {typed, _, _, ExprType} = infer_expr(Env, Expr), + SwitchType = fresh_uvar(Attrs), + NewCases = [infer_case(Env, As, Pattern, ExprType, Branch, SwitchType) + || {'case', As, Pattern, Branch} <- Cases], + {typed, Attrs, {switch, Attrs, NewExpr, NewCases}, SwitchType}; +infer_expr(Env, {record, Attrs, Fields}) -> + RecordType = fresh_uvar(Attrs), + NewFields = [{field, A, FieldName, infer_expr(Env, Expr)} + || {field, A, FieldName, Expr} <- Fields], + constrain([begin + [{proj, _, FieldName}] = LV, + #field_constraint{ + record_t = unfold_types_in_type(RecordType), + field = FieldName, + field_t = T, + kind = create, + context = Fld} + end || {Fld, {field, _, LV, {typed, _, _, T}}} <- lists:zip(Fields, NewFields)]), + {typed, Attrs, {record, Attrs, NewFields}, RecordType}; +infer_expr(Env, {record, Attrs, Record, Update}) -> + NewRecord = {typed, _, _, RecordType} = infer_expr(Env, Record), + NewUpdate = [ check_record_update(Env, RecordType, Fld) || Fld <- Update ], + {typed, Attrs, {record, Attrs, NewRecord, NewUpdate}, RecordType}; +infer_expr(Env, {proj, Attrs, Record, FieldName}) -> + NewRecord = {typed, _, _, RecordType} = infer_expr(Env, Record), + FieldType = fresh_uvar(Attrs), + constrain([#field_constraint{ + record_t = unfold_types_in_type(RecordType), + field = FieldName, + field_t = FieldType, + kind = project, + context = {proj, Attrs, Record, FieldName} }]), + {typed, Attrs, {proj, Attrs, NewRecord, FieldName}, FieldType}; +%% Maps +infer_expr(Env, {map_get, Attrs, Map, Key}) -> %% map lookup + KeyType = fresh_uvar(Attrs), + ValType = fresh_uvar(Attrs), + MapType = map_t(Attrs, KeyType, ValType), + Map1 = check_expr(Env, Map, MapType), + Key1 = check_expr(Env, Key, KeyType), + {typed, Attrs, {map_get, Attrs, Map1, Key1}, ValType}; +infer_expr(Env, {map_get, Attrs, Map, Key, Val}) -> %% map lookup with default + KeyType = fresh_uvar(Attrs), + ValType = fresh_uvar(Attrs), + MapType = map_t(Attrs, KeyType, ValType), + Map1 = check_expr(Env, Map, MapType), + Key1 = check_expr(Env, Key, KeyType), + Val1 = check_expr(Env, Val, ValType), + {typed, Attrs, {map_get, Attrs, Map1, Key1, Val1}, ValType}; +infer_expr(Env, {map, Attrs, KVs}) -> %% map construction + KeyType = fresh_uvar(Attrs), + ValType = fresh_uvar(Attrs), + KVs1 = [ {check_expr(Env, K, KeyType), check_expr(Env, V, ValType)} + || {K, V} <- KVs ], + {typed, Attrs, {map, Attrs, KVs1}, map_t(Attrs, KeyType, ValType)}; +infer_expr(Env, {map, Attrs, Map, Updates}) -> %% map update + KeyType = fresh_uvar(Attrs), + ValType = fresh_uvar(Attrs), + MapType = map_t(Attrs, KeyType, ValType), + Map1 = check_expr(Env, Map, MapType), + Updates1 = [ check_map_update(Env, Upd, KeyType, ValType) || Upd <- Updates ], + {typed, Attrs, {map, Attrs, Map1, Updates1}, MapType}; +infer_expr(Env, {block, Attrs, Stmts}) -> + BlockType = fresh_uvar(Attrs), + NewStmts = infer_block(Env, Attrs, Stmts, BlockType), + {typed, Attrs, {block, Attrs, NewStmts}, BlockType}; +infer_expr(Env, {lam, Attrs, Args, Body}) -> + ArgTypes = [fresh_uvar(As) || {arg, As, _, _} <- Args], + ArgPatterns = [{typed, As, Pat, T} || {arg, As, Pat, T} <- Args], + ResultType = fresh_uvar(Attrs), + {'case', _, {typed, _, {tuple, _, NewArgPatterns}, _}, NewBody} = + infer_case(Env, Attrs, {tuple, Attrs, ArgPatterns}, {tuple_t, Attrs, ArgTypes}, Body, ResultType), + NewArgs = [{arg, As, NewPat, NewT} || {typed, As, NewPat, NewT} <- NewArgPatterns], + {typed, Attrs, {lam, Attrs, NewArgs, NewBody}, {fun_t, Attrs, [], ArgTypes, ResultType}}. + +infer_named_arg(Env, NamedArgs, {named_arg, Ann, Id, E}) -> + CheckedExpr = {typed, _, _, ArgType} = infer_expr(Env, E), + add_named_argument_constraint( + #named_argument_constraint{ + args = NamedArgs, + name = Id, + type = ArgType }), + {named_arg, Ann, Id, CheckedExpr}. + +check_map_update(Env, {field, Ann, [{map_get, Ann1, Key}], Val}, KeyType, ValType) -> + Key1 = check_expr(Env, Key, KeyType), + Val1 = check_expr(Env, Val, ValType), + {field, Ann, [{map_get, Ann1, Key1}], Val1}; +check_map_update(_Env, Upd={field, _Ann, [{map_get, _Ann1, _Key, _Def}], _Val}, _KeyType, _ValType) -> + type_error({unnamed_map_update_with_default, Upd}); +check_map_update(Env, {field, Ann, [{map_get, Ann1, Key}], Id, Val}, KeyType, ValType) -> + FunType = {fun_t, Ann, [], [ValType], ValType}, + Key1 = check_expr(Env, Key, KeyType), + Fun = check_expr(Env, {lam, Ann1, [{arg, Ann1, Id, ValType}], Val}, FunType), + {field_upd, Ann, [{map_get, Ann1, Key1}], Fun}; +check_map_update(Env, {field, Ann, [{map_get, Ann1, Key, Def}], Id, Val}, KeyType, ValType) -> + FunType = {fun_t, Ann, [], [ValType], ValType}, + Key1 = check_expr(Env, Key, KeyType), + Def1 = check_expr(Env, Def, ValType), + Fun = check_expr(Env, {lam, Ann1, [{arg, Ann1, Id, ValType}], Val}, FunType), + {field_upd, Ann, [{map_get, Ann1, Key1, Def1}], Fun}; +check_map_update(_, {field, Ann, Flds, _}, _, _) -> + error({nested_map_updates_not_implemented, Ann, Flds}). + +check_record_update(Env, RecordType, Fld) -> + [field, Ann, LV = [{proj, Ann1, FieldName}] | Val] = tuple_to_list(Fld), + FldType = fresh_uvar(Ann), + Fld1 = case Val of + [Expr] -> + {field, Ann, LV, check_expr(Env, Expr, FldType)}; + [Id, Expr] -> + Fun = {lam, Ann1, [{arg, Ann1, Id, FldType}], Expr}, + FunType = {fun_t, Ann1, [], [FldType], FldType}, + {field_upd, Ann, LV, check_expr(Env, Fun, FunType)} + end, + constrain([#field_constraint{ + record_t = unfold_types_in_type(RecordType), + field = FieldName, + field_t = FldType, + kind = update, + context = Fld }]), + Fld1. + +infer_op(Env, As, Op, Args, InferOp) -> + TypedArgs = [infer_expr(Env, A) || A <- Args], + ArgTypes = [T || {typed, _, _, T} <- TypedArgs], + Inferred = {fun_t, _, _, OperandTypes, ResultType} = InferOp(Op), + unify(ArgTypes, OperandTypes, {infer_app, Op, Args, Inferred, ArgTypes}), + {typed, As, {app, As, Op, TypedArgs}, ResultType}. + +infer_case(Env, Attrs, Pattern, ExprType, Branch, SwitchType) -> + Vars = free_vars(Pattern), + Names = [N || {id, _, N} <- Vars, N /= "_"], + case Names -- lists:usort(Names) of + [] -> ok; + Nonlinear -> type_error({non_linear_pattern, Pattern, lists:usort(Nonlinear)}) + end, + NewEnv = [{Name, fresh_uvar(Attr)} || {id, Attr, Name} <- Vars] ++ Env, + NewPattern = {typed, _, _, PatType} = infer_expr(NewEnv, Pattern), + NewBranch = check_expr(NewEnv, Branch, SwitchType), + unify(PatType, ExprType, {case_pat, Pattern, PatType, ExprType}), + {'case', Attrs, NewPattern, NewBranch}. + +%% NewStmts = infer_block(Env, Attrs, Stmts, BlockType) +infer_block(_Env, Attrs, [], BlockType) -> + error({impossible, empty_block, Attrs, BlockType}); +infer_block(Env, Attrs, [Def={letfun, _, _, _, _, _}|Rest], BlockType) -> + NewDef = infer_letfun(Env, Def), + [NewDef|infer_block(Env, Attrs, Rest, BlockType)]; +infer_block(Env, Attrs, [Def={letrec, _, _}|Rest], BlockType) -> + NewDef = infer_letrec(Env, Def), + [NewDef|infer_block(Env, Attrs, Rest, BlockType)]; +infer_block(Env, _, [{letval, Attrs, Pattern, Type, E}|Rest], BlockType) -> + NewE = {typed, _, _, PatType} = infer_expr(Env, {typed, Attrs, E, arg_type(Type)}), + {'case', _, NewPattern, {typed, _, {block, _, NewRest}, _}} = + infer_case(Env, Attrs, Pattern, PatType, {block, Attrs, Rest}, BlockType), + [{letval, Attrs, NewPattern, Type, NewE}|NewRest]; +infer_block(Env, _, [E], BlockType) -> + [check_expr(Env, E, BlockType)]; +infer_block(Env, Attrs, [E|Rest], BlockType) -> + [infer_expr(Env, E)|infer_block(Env, Attrs, Rest, BlockType)]. + +infer_infix({BoolOp, As}) + when BoolOp =:= '&&'; BoolOp =:= '||' -> + Bool = {id, As, "bool"}, + {fun_t, As, [], [Bool,Bool], Bool}; +infer_infix({IntOp, As}) + when IntOp == '+'; IntOp == '-'; IntOp == '*'; IntOp == '/'; + IntOp == '^'; IntOp == 'mod'; IntOp == 'bsl'; IntOp == 'bsr'; + IntOp == 'band'; IntOp == 'bor'; IntOp == 'bxor' -> + Int = {id, As, "int"}, + {fun_t, As, [], [Int, Int], Int}; +infer_infix({RelOp, As}) + when RelOp == '=='; RelOp == '!='; + RelOp == '<'; RelOp == '>'; + RelOp == '<='; RelOp == '=<'; RelOp == '>=' -> + T = fresh_uvar(As), %% allow any type here, check in ast_to_icode that we have comparison for it + Bool = {id, As, "bool"}, + {fun_t, As, [], [T, T], Bool}; +infer_infix({'::', As}) -> + ElemType = fresh_uvar(As), + ListType = {app_t, As, {id, As, "list"}, [ElemType]}, + {fun_t, As, [], [ElemType, ListType], ListType}; +infer_infix({'++', As}) -> + ElemType = fresh_uvar(As), + ListType = {app_t, As, {id, As, "list"}, [ElemType]}, + {fun_t, As, [], [ListType, ListType], ListType}. + +infer_prefix({'!',As}) -> + Bool = {id, As, "bool"}, + {fun_t, As, [], [Bool], Bool}; +infer_prefix({IntOp,As}) + when IntOp =:= '-'; IntOp =:= 'bnot' -> + Int = {id, As, "int"}, + {fun_t, As, [], [Int], Int}. + +free_vars({int, _, _}) -> + []; +free_vars({string, _, _}) -> + []; +free_vars({bool, _, _}) -> + []; +free_vars(Id={id, _, _}) -> + [Id]; +free_vars({con, _, _}) -> + []; +free_vars({tuple, _, Cpts}) -> + free_vars(Cpts); +free_vars({list, _, Elems}) -> + free_vars(Elems); +free_vars({app, _, {'::', _}, Args}) -> + free_vars(Args); +free_vars({app, _, {con, _, _}, Args}) -> + free_vars(Args); +free_vars({record, _, Fields}) -> + free_vars([E || {field, _, _, E} <- Fields]); +free_vars({typed, _, A, _}) -> + free_vars(A); +free_vars(L) when is_list(L) -> + [V || Elem <- L, + V <- free_vars(Elem)]. + +%% Clean up all the ets tables (in case of an exception) + +ets_tables() -> + [options, type_vars, type_defs, record_fields, named_argument_constraints, + field_constraints, freshen_tvars, type_errors]. + +clean_up_ets() -> + [ catch ets_delete(Tab) || Tab <- ets_tables() ], + ok. + +%% Named interface to ETS tables implemented without names. +%% The interface functions behave as the standard ETS interface. + +ets_init() -> + put(aeso_ast_infer_types, #{}). + +ets_tabid(Name) -> + #{Name := TabId} = get(aeso_ast_infer_types), + TabId. + +ets_new(Name, Opts) -> + %% Ensure the table is NOT named! + TabId = ets:new(Name, Opts -- [named_table]), + Tabs = get(aeso_ast_infer_types), + put(aeso_ast_infer_types, Tabs#{Name => TabId}), + Name. + +ets_delete(Name) -> + Tabs = get(aeso_ast_infer_types), + #{Name := TabId} = Tabs, + put(aeso_ast_infer_types, maps:remove(Name, Tabs)), + ets:delete(TabId). + +ets_insert(Name, Object) -> + TabId = ets_tabid(Name), + ets:insert(TabId, Object). + +ets_lookup(Name, Key) -> + TabId = ets_tabid(Name), + ets:lookup(TabId, Key). + +ets_tab2list(Name) -> + TabId = ets_tabid(Name), + ets:tab2list(TabId). + +%% Options + +create_options(Options) -> + ets_new(options, [set]), + Tup = fun(Opt) when is_atom(Opt) -> {Opt, true}; + (Opt) when is_tuple(Opt) -> Opt end, + ets_insert(options, lists:map(Tup, Options)). + +get_option(Key, Default) -> + case ets_lookup(options, Key) of + [{Key, Val}] -> Val; + _ -> Default + end. + +when_option(Opt, Do) -> + get_option(Opt, false) andalso Do(). + +%% Record types + +create_type_defs(Defs) -> + %% A map from type names to definitions + ets_new(type_defs, [set]), + %% A relation from field names to types + ets_new(record_fields, [bag]), + [ case Def of + {type_def, _Attrs, Id, Args, Typedef} -> + insert_typedef(Id, Args, Typedef); + {contract, _Attrs, Id, Contents} -> + insert_contract(Id, Contents); + _ -> ok + end || Def <- Defs], + ok. + +destroy_type_defs() -> + ets_delete(type_defs), + ets_delete(record_fields). + +%% Key used in type_defs ets table. +-spec type_key(type_id()) -> [string()]. +type_key({Tag, _, Name}) when Tag =:= id; Tag =:= con -> [Name]; +type_key({Tag, _, QName}) when Tag =:= qid; Tag =:= qcon -> QName. + +%% Contract entrypoints take two named arguments (gas : int = Call.gas_left(), value : int = 0). +contract_call_type({fun_t, Ann, [], Args, Ret}) -> + Id = fun(X) -> {id, Ann, X} end, + Int = Id("int"), + Typed = fun(E, T) -> {typed, Ann, E, T} end, + Named = fun(Name, Default) -> {named_arg_t, Ann, Id(Name), Int, Default} end, + {fun_t, Ann, [Named("gas", Typed({app, Ann, Typed({qid, Ann, ["Call", "gas_left"]}, + {fun_t, Ann, [], [], Int}), + []}, Int)), + Named("value", Typed({int, Ann, 0}, Int))], Args, Ret}. + +insert_contract(Id, Contents) -> + Key = type_key(Id), + Sys = [{origin, system}], + Fields = [ {field_t, Ann, Entrypoint, contract_call_type(Type)} + || {fun_decl, Ann, Entrypoint, Type} <- Contents ] ++ + %% Predefined fields + [ {field_t, Sys, {id, Sys, "address"}, {id, Sys, "address"}} ], + ets_insert(type_defs, {Key, [], {contract_t, Fields}}), + %% TODO: types defined in other contracts + [insert_record_field(Entrypoint, #field_info{ kind = contract, + field_t = Type, + record_t = Id }) + || {field_t, _, {id, _, Entrypoint}, Type} <- Fields ]. + +-spec insert_typedef(type_id(), [aeso_syntax:tvar()], aeso_syntax:typedef()) -> ok. +insert_typedef(Id, Args, Typedef) -> + Attrs = aeso_syntax:get_ann(Id), + Key = type_key(Id), + ets_insert(type_defs, {Key, Args, Typedef}), + case Typedef of + {record_t, Fields} -> + [insert_record_field(FieldName, #field_info{ kind = record, + field_t = FieldType, + record_t = {app_t, Attrs, Id, Args} }) + || {field_t, _, {id, _, FieldName}, FieldType} <- Fields], + ok; + {variant_t, _} -> ok; + {alias_t, _} -> ok + end. + +-spec lookup_type(type_id()) -> false | {[aeso_syntax:tvar()], aeso_syntax:typedef()}. +lookup_type(Id) -> + case ets_lookup(type_defs, type_key(Id)) of + [] -> false; + [{_Key, Params, Typedef}] -> + {Params, unfold_types_in_type(push_anns(Id, Typedef))} + end. + +push_anns(T1, {alias_t, Id}) -> + As1 = aeso_syntax:get_ann(T1), + As2 = aeso_syntax:get_ann(Id), + As = umerge(lists:sort(As2), lists:sort(As1)), + {alias_t, aeso_syntax:set_ann(As, Id)}; +push_anns(_, T) -> T. + +umerge([], Ls2) -> Ls2; +umerge(Ls1, []) -> Ls1; +umerge([E = {K, _V1} | Ls1], [{K, _V2} | Ls2]) -> + [E | umerge(Ls1, Ls2)]; +umerge([E = {K1, _V1} | Ls1], Ls2 = [{K2, _V2} | _]) when K1 < K2 -> + [E | umerge(Ls1, Ls2)]; +umerge(Ls1 = [{K1, _V1} | _], [E = {K2, _V2} | Ls2]) when K2 < K1 -> + [E | umerge(Ls1, Ls2)]. + + +-spec insert_record_field(string(), field_info()) -> true. +insert_record_field(FieldName, FieldInfo) -> + ets_insert(record_fields, {FieldName, FieldInfo}). + +-spec lookup_record_field(string()) -> [{string(), field_info()}]. +lookup_record_field(FieldName) -> + ets_lookup(record_fields, FieldName). + +%% For 'create' or 'update' constraints we don't consider contract types. +lookup_record_field(FieldName, Kind) -> + [ Fld || Fld = {_, #field_info{ kind = K }} <- lookup_record_field(FieldName), + Kind == project orelse K /= contract ]. + +%% -- Constraints -- + +create_constraints() -> + create_named_argument_constraints(), + create_field_constraints(). + +solve_constraints() -> + solve_named_argument_constraints(), + solve_field_constraints(). + +destroy_and_report_unsolved_constraints() -> + destroy_and_report_unsolved_field_constraints(), + destroy_and_report_unsolved_named_argument_constraints(). + +%% -- Named argument constraints -- + +create_named_argument_constraints() -> + ets_new(named_argument_constraints, [bag]). + +destroy_named_argument_constraints() -> + ets_delete(named_argument_constraints). + +get_named_argument_constraints() -> + ets_tab2list(named_argument_constraints). + +-spec add_named_argument_constraint(named_argument_constraint()) -> ok. +add_named_argument_constraint(Constraint) -> + ets_insert(named_argument_constraints, Constraint), + ok. + +solve_named_argument_constraints() -> + Unsolved = solve_named_argument_constraints(get_named_argument_constraints()), + Unsolved == []. + +-spec solve_named_argument_constraints([named_argument_constraint()]) -> [named_argument_constraint()]. +solve_named_argument_constraints(Constraints0) -> + [ C || C <- dereference_deep(Constraints0), + unsolved == check_named_argument_constraint(C) ]. + +%% If false, a type error have been emitted, so it's safe to drop the constraint. +-spec check_named_argument_constraint(named_argument_constraint()) -> true | false | unsolved. +check_named_argument_constraint(#named_argument_constraint{ args = {uvar, _, _} }) -> + unsolved; +check_named_argument_constraint( + C = #named_argument_constraint{ args = Args, + name = Id = {id, _, Name}, + type = Type }) -> + case [ T || {named_arg_t, _, {id, _, Name1}, T, _} <- Args, Name1 == Name ] of + [] -> + type_error({bad_named_argument, Args, Id}), + false; + [T] -> unify(T, Type, {check_named_arg_constraint, C}), true + end. + +destroy_and_report_unsolved_named_argument_constraints() -> + Unsolved = solve_named_argument_constraints(get_named_argument_constraints()), + [ type_error({unsolved_named_argument_constraint, C}) || C <- Unsolved ], + destroy_named_argument_constraints(), + ok. + +%% -- Field constraints -- + +create_field_constraints() -> + %% A relation from uvars to constraints + ets_new(field_constraints, [bag]). + +destroy_field_constraints() -> + ets_delete(field_constraints). + +-spec constrain([field_constraint()]) -> true. +constrain(FieldConstraints) -> + ets_insert(field_constraints, FieldConstraints). + +-spec get_field_constraints() -> [field_constraint()]. +get_field_constraints() -> + ets_tab2list(field_constraints). + +solve_field_constraints() -> + solve_field_constraints(get_field_constraints()). + +-spec solve_field_constraints([field_constraint()]) -> ok. +solve_field_constraints(Constraints) -> + %% First look for record fields that appear in only one type definition + IsAmbiguous = fun(#field_constraint{ + record_t = RecordType, + field = Field={id, _Attrs, FieldName}, + field_t = FieldType, + kind = Kind, + context = When }) -> + case lookup_record_field(FieldName, Kind) of + [] -> + type_error({undefined_field, Field}), + false; + [{FieldName, #field_info{field_t = FldType, record_t = RecType}}] -> + create_freshen_tvars(), + FreshFldType = freshen(FldType), + FreshRecType = freshen(RecType), + destroy_freshen_tvars(), + unify(FreshFldType, FieldType, {field_constraint, FreshFldType, FieldType, When}), + unify(FreshRecType, RecordType, {record_constraint, FreshRecType, RecordType, When}), + false; + _ -> + %% ambiguity--need cleverer strategy + true + end end, + AmbiguousConstraints = lists:filter(IsAmbiguous, Constraints), + solve_ambiguous_field_constraints(AmbiguousConstraints). + +-spec solve_ambiguous_field_constraints([field_constraint()]) -> ok. +solve_ambiguous_field_constraints(Constraints) -> + Unknown = solve_known_record_types(Constraints), + if Unknown == [] -> ok; + length(Unknown) < length(Constraints) -> + %% progress! Keep trying. + solve_ambiguous_field_constraints(Unknown); + true -> + case solve_unknown_record_types(Unknown) of + true -> %% Progress! + solve_ambiguous_field_constraints(Unknown); + _ -> ok %% No progress. Report errors later. + end + end. + +-spec solve_unknown_record_types([field_constraint()]) -> true | [tuple()]. +solve_unknown_record_types(Unknown) -> + UVars = lists:usort([UVar || #field_constraint{record_t = UVar = {uvar, _, _}} <- Unknown]), + Solutions = [solve_for_uvar(UVar, [{Kind, Field} + || #field_constraint{record_t = U, field = Field, kind = Kind} <- Unknown, + U == UVar]) + || UVar <- UVars], + case lists:member(true, Solutions) of + true -> true; + false -> Solutions + end. + +-spec solve_known_record_types([field_constraint()]) -> [field_constraint()]. +solve_known_record_types(Constraints) -> + DerefConstraints = + [ C#field_constraint{record_t = dereference(RecordType)} + || C = #field_constraint{record_t = RecordType} <- Constraints ], + SolvedConstraints = + [begin + #field_constraint{record_t = RecType, + field = FieldName, + field_t = FieldType, + context = When} = C, + RecId = record_type_name(RecType), + Attrs = aeso_syntax:get_ann(RecId), + case lookup_type(RecId) of + {Formals, {What, Fields}} when What =:= record_t; What =:= contract_t -> + FieldTypes = [{Name, Type} || {field_t, _, {id, _, Name}, Type} <- Fields], + {id, _, FieldString} = FieldName, + case proplists:get_value(FieldString, FieldTypes) of + undefined -> + type_error({missing_field, FieldName, RecId}), + not_solved; + FldType -> + create_freshen_tvars(), + FreshFldType = freshen(FldType), + FreshRecType = freshen({app_t, Attrs, RecId, Formals}), + destroy_freshen_tvars(), + unify(FreshFldType, FieldType, {field_constraint, FreshFldType, FieldType, When}), + unify(FreshRecType, RecType, {record_constraint, FreshRecType, RecType, When}), + C + end; + false -> + type_error({not_a_record_type, RecId, When}), + not_solved + end + end + || C <- DerefConstraints, + case C#field_constraint.record_t of + {uvar, _, _} -> false; + _ -> true + end], + DerefConstraints--SolvedConstraints. + +destroy_and_report_unsolved_field_constraints() -> + Unsolved = get_field_constraints(), + Unknown = solve_known_record_types(Unsolved), + if Unknown == [] -> ok; + true -> + case solve_unknown_record_types(Unknown) of + true -> ok; + Errors -> [ type_error(Err) || Err <- Errors ] + end + end, + destroy_field_constraints(), + ok. + +record_type_name({app_t, _Attrs, RecId, _Args}) when ?is_type_id(RecId) -> + RecId; +record_type_name(RecId) when ?is_type_id(RecId) -> + RecId. + +solve_for_uvar(UVar = {uvar, Attrs, _}, Fields) -> + %% If we have 'create' constraints they must be complete. + Covering = lists:usort([ Name || {create, {id, _, Name}} <- Fields ]), + %% Does this set of fields uniquely identify a record type? + FieldNames = [ Name || {_Kind, {id, _, Name}} <- Fields ], + UniqueFields = lists:usort(FieldNames), + Candidates = [record_type_name(RecType) || {_, #field_info{record_t = RecType}} <- lookup_record_field(hd(FieldNames))], + TypesAndFields = [case lookup_type(RecName) of + {_, {record_t, RecFields}} -> + {RecName, [Field || {field_t, _, {id, _, Field}, _} <- RecFields]}; + _ -> %% impossible? + error({no_definition_for, RecName, in, Candidates}) + end + || RecName <- Candidates], + Solutions = lists:sort([RecName || {RecName, RecFields} <- TypesAndFields, + UniqueFields -- RecFields == [], + Covering == [] orelse RecFields -- Covering == []]), + case Solutions of + [] -> + {no_records_with_all_fields, Fields}; + [RecId] -> + {Formals, {record_t, _}} = lookup_type(RecId), + create_freshen_tvars(), + FreshRecType = freshen({app_t, Attrs, RecId, Formals}), + destroy_freshen_tvars(), + unify(UVar, FreshRecType, {solve_rec_type, UVar, Fields}), + true; + StillPossible -> + {ambiguous_record, Fields, StillPossible} + end. + +%% During type inference, record types are represented by their +%% names. But, before we pass the typed program to the code generator, +%% we replace record types annotating expressions with their +%% definition. This enables the code generator to see the fields. +unfold_record_types(T) -> + unfold_types(T, [unfold_record_types]). + +unfold_types({typed, Attr, E, Type}, Options) -> + {typed, Attr, unfold_types(E, Options), unfold_types_in_type(Type, Options)}; +unfold_types({arg, Attr, Id, Type}, Options) -> + {arg, Attr, Id, unfold_types_in_type(Type, Options)}; +unfold_types({type_sig, Ann, NamedArgs, Args, Ret}, Options) -> + {type_sig, Ann, + unfold_types_in_type(NamedArgs, Options), + unfold_types_in_type(Args, Options), + unfold_types_in_type(Ret, Options)}; +unfold_types({type_def, Ann, Name, Args, Def}, Options) -> + {type_def, Ann, Name, Args, unfold_types_in_type(Def, Options)}; +unfold_types({letfun, Ann, Name, Args, Type, Body}, Options) -> + {letfun, Ann, Name, unfold_types(Args, Options), unfold_types_in_type(Type, Options), unfold_types(Body, Options)}; +unfold_types(T, Options) when is_tuple(T) -> + list_to_tuple(unfold_types(tuple_to_list(T), Options)); +unfold_types([H|T], Options) -> + [unfold_types(H, Options)|unfold_types(T, Options)]; +unfold_types(X, _Options) -> + X. + +unfold_types_in_type(T) -> + unfold_types_in_type(T, []). + +unfold_types_in_type({app_t, Ann, Id, Args}, Options) when ?is_type_id(Id) -> + UnfoldRecords = proplists:get_value(unfold_record_types, Options, false), + case lookup_type(Id) of + {Formals, {record_t, Fields}} when UnfoldRecords, length(Formals) == length(Args) -> + {record_t, + unfold_types_in_type( + subst_tvars(lists:zip(Formals, Args), Fields), Options)}; + {Formals, {alias_t, Type}} when length(Formals) == length(Args) -> + unfold_types_in_type(subst_tvars(lists:zip(Formals, Args), Type), Options); + _ -> + %% Not a record type, or ill-formed record type. + {app_t, Ann, Id, unfold_types_in_type(Args, Options)} + end; +unfold_types_in_type(Id, Options) when ?is_type_id(Id) -> + %% Like the case above, but for types without parameters. + UnfoldRecords = proplists:get_value(unfold_record_types, Options, false), + case lookup_type(Id) of + {[], {record_t, Fields}} when UnfoldRecords -> + {record_t, unfold_types_in_type(Fields, Options)}; + {[], {alias_t, Type1}} -> + unfold_types_in_type(Type1, Options); + _ -> + %% Not a record type, or ill-formed record type + Id + end; +unfold_types_in_type({field_t, Attr, Name, Type}, Options) -> + {field_t, Attr, Name, unfold_types_in_type(Type, Options)}; +unfold_types_in_type(T, Options) when is_tuple(T) -> + list_to_tuple(unfold_types_in_type(tuple_to_list(T), Options)); +unfold_types_in_type([H|T], Options) -> + [unfold_types_in_type(H, Options)|unfold_types_in_type(T, Options)]; +unfold_types_in_type(X, _Options) -> + X. + + +subst_tvars(Env, Type) -> + subst_tvars1([{V, T} || {{tvar, _, V}, T} <- Env], Type). + +subst_tvars1(Env, T={tvar, _, Name}) -> + proplists:get_value(Name, Env, T); +subst_tvars1(Env, [H|T]) -> + [subst_tvars1(Env, H)|subst_tvars1(Env, T)]; +subst_tvars1(Env, Type) when is_tuple(Type) -> + list_to_tuple(subst_tvars1(Env, tuple_to_list(Type))); +subst_tvars1(_Env, X) -> + X. + +%% Unification + +unify({id, _, "_"}, _, _When) -> true; +unify(_, {id, _, "_"}, _When) -> true; +unify(A, B, When) -> + A1 = dereference(unfold_types_in_type(A)), + B1 = dereference(unfold_types_in_type(B)), + unify1(A1, B1, When). + +unify1({uvar, _, R}, {uvar, _, R}, _When) -> + true; +unify1({uvar, A, R}, T, When) -> + case occurs_check(R, T) of + true -> + cannot_unify({uvar, A, R}, T, When), + false; + false -> + ets_insert(type_vars, {R, T}), + true + end; +unify1(T, {uvar, A, R}, When) -> + unify1({uvar, A, R}, T, When); +unify1({tvar, _, X}, {tvar, _, X}, _When) -> true; %% Rigid type variables +unify1([A|B], [C|D], When) -> + unify(A, C, When) andalso unify(B, D, When); +unify1(X, X, _When) -> + true; +unify1({id, _, Name}, {id, _, Name}, _When) -> + true; +unify1({con, _, Name}, {con, _, Name}, _When) -> + true; +unify1({qid, _, Name}, {qid, _, Name}, _When) -> + true; +unify1({qcon, _, Name}, {qcon, _, Name}, _When) -> + true; +unify1({fun_t, _, Named1, Args1, Result1}, {fun_t, _, Named2, Args2, Result2}, When) -> + unify(Named1, Named2, When) andalso + unify(Args1, Args2, When) andalso unify(Result1, Result2, When); +unify1({app_t, _, {id, _, F}, Args1}, {app_t, _, {id, _, F}, Args2}, When) + when length(Args1) == length(Args2) -> + unify(Args1, Args2, When); +unify1({tuple_t, _, As}, {tuple_t, _, Bs}, When) + when length(As) == length(Bs) -> + unify(As, Bs, When); +%% The grammar is a bit inconsistent about whether types without +%% arguments are represented as applications to an empty list of +%% parameters or not. We therefore allow them to unify. +unify1({app_t, _, T, []}, B, When) -> + unify(T, B, When); +unify1(A, {app_t, _, T, []}, When) -> + unify(A, T, When); +unify1(A, B, When) -> + Ok = + case get_option(permissive_address_literals, false) of + true -> + Kind = fun({qcon, _, _}) -> con; + ({con, _, _}) -> con; + ({id, _, "address"}) -> addr; + (_) -> other end, + %% If permissive_address_literals we allow unifying contract types and address + [addr, con] == lists:usort([Kind(A), Kind(B)]); + false -> false + end, + [ cannot_unify(A, B, When) || not Ok ], + Ok. + +dereference(T = {uvar, _, R}) -> + case ets_lookup(type_vars, R) of + [] -> + T; + [{R, Type}] -> + dereference(Type) + end; +dereference(T) -> + T. + +dereference_deep(Type) -> + case dereference(Type) of + Tup when is_tuple(Tup) -> + list_to_tuple(dereference_deep(tuple_to_list(Tup))); + [H | T] -> [dereference_deep(H) | dereference_deep(T)]; + T -> T + end. + +occurs_check(R, T) -> + occurs_check1(R, dereference(T)). + +occurs_check1(R, {uvar, _, R1}) -> R == R1; +occurs_check1(_, {id, _, _}) -> false; +occurs_check1(_, {con, _, _}) -> false; +occurs_check1(_, {qid, _, _}) -> false; +occurs_check1(_, {qcon, _, _}) -> false; +occurs_check1(_, {tvar, _, _}) -> false; +occurs_check1(R, {fun_t, _, Named, Args, Res}) -> + occurs_check(R, [Res, Named | Args]); +occurs_check1(R, {app_t, _, T, Ts}) -> + occurs_check(R, [T | Ts]); +occurs_check1(R, {tuple_t, _, Ts}) -> + occurs_check(R, Ts); +occurs_check1(R, {named_arg_t, _, _, T, _}) -> + occurs_check(R, T); +occurs_check1(R, [H | T]) -> + occurs_check(R, H) orelse occurs_check(R, T); +occurs_check1(_, []) -> false. + +fresh_uvar(Attrs) -> + {uvar, Attrs, make_ref()}. + +create_freshen_tvars() -> + ets_new(freshen_tvars, [set]). + +destroy_freshen_tvars() -> + ets_delete(freshen_tvars). + +freshen_type(Type) -> + create_freshen_tvars(), + Type1 = freshen(Type), + destroy_freshen_tvars(), + Type1. + +freshen({tvar, As, Name}) -> + NewT = case ets_lookup(freshen_tvars, Name) of + [] -> + fresh_uvar(As); + [{Name, T}] -> + T + end, + ets_insert(freshen_tvars, {Name, NewT}), + NewT; +freshen(T) when is_tuple(T) -> + list_to_tuple(freshen(tuple_to_list(T))); +freshen([A|B]) -> + [freshen(A)|freshen(B)]; +freshen(X) -> + X. + +%% Dereferences all uvars and replaces the uninstantiated ones with a +%% succession of tvars. +instantiate(E) -> + instantiate1(dereference(E)). + +instantiate1({uvar, Attr, R}) -> + Next = proplists:get_value(next, ets_lookup(type_vars, next), 1), + TVar = {tvar, Attr, "'" ++ integer_to_list(Next)}, + ets_insert(type_vars, [{next, Next + 1}, {R, TVar}]), + TVar; +instantiate1({fun_t, Ann, Named, Args, Ret}) -> + case dereference(Named) of + {uvar, _, R} -> + %% Uninstantiated named args map to the empty list + NoNames = [], + ets_insert(type_vars, [{R, NoNames}]), + {fun_t, Ann, NoNames, instantiate(Args), instantiate(Ret)}; + Named1 -> + {fun_t, Ann, instantiate1(Named1), instantiate(Args), instantiate(Ret)} + end; +instantiate1(T) when is_tuple(T) -> + list_to_tuple(instantiate1(tuple_to_list(T))); +instantiate1([A|B]) -> + [instantiate(A)|instantiate(B)]; +instantiate1(X) -> + X. + +%% Save unification failures for error messages. + +cannot_unify(A, B, When) -> + type_error({cannot_unify, A, B, When}). + +type_error(Err) -> + ets_insert(type_errors, Err). + +create_type_errors() -> + ets_new(type_errors, [bag]). + +destroy_and_report_type_errors() -> + Errors = ets_tab2list(type_errors), + %% io:format("Type errors now: ~p\n", [Errors]), + PPErrors = [ pp_error(Err) || Err <- Errors ], + ets_delete(type_errors), + Errors /= [] andalso + error({type_errors, [lists:flatten(Err) || Err <- PPErrors]}). + +pp_error({cannot_unify, A, B, When}) -> + io_lib:format("Cannot unify ~s\n" + " and ~s\n" + "~s", [pp(instantiate(A)), pp(instantiate(B)), pp_when(When)]); +pp_error({unbound_variable, Id}) -> + io_lib:format("Unbound variable ~s at ~s\n", [pp(Id), pp_loc(Id)]); +pp_error({undefined_field, Id}) -> + io_lib:format("Unbound field ~s at ~s\n", [pp(Id), pp_loc(Id)]); +pp_error({not_a_record_type, Type, Why}) -> + io_lib:format("~s\n~s\n", [pp_type("Not a record type: ", Type), pp_why_record(Why)]); +pp_error({non_linear_pattern, Pattern, Nonlinear}) -> + Plural = [ $s || length(Nonlinear) > 1 ], + io_lib:format("Repeated name~s ~s in pattern\n~s (at ~s)\n", + [Plural, string:join(Nonlinear, ", "), pp_expr(" ", Pattern), pp_loc(Pattern)]); +pp_error({ambiguous_record, Fields = [{_, First} | _], Candidates}) -> + S = [ "s" || length(Fields) > 1 ], + io_lib:format("Ambiguous record type with field~s ~s (at ~s) could be one of\n~s", + [S, string:join([ pp(F) || {_, F} <- Fields ], ", "), + pp_loc(First), + [ [" - ", pp(C), " (at ", pp_loc(C), ")\n"] || C <- Candidates ]]); +pp_error({missing_field, Field, Rec}) -> + io_lib:format("Record type ~s does not have field ~s (at ~s)\n", [pp(Rec), pp(Field), pp_loc(Field)]); +pp_error({no_records_with_all_fields, Fields = [{_, First} | _]}) -> + S = [ "s" || length(Fields) > 1 ], + io_lib:format("No record type with field~s ~s (at ~s)\n", + [S, string:join([ pp(F) || {_, F} <- Fields ], ", "), + pp_loc(First)]); +pp_error({recursive_types_not_implemented, Types}) -> + S = if length(Types) > 1 -> "s are mutually"; + true -> " is" end, + io_lib:format("The following type~s recursive, which is not yet supported:\n~s", + [S, [io_lib:format(" - ~s (at ~s)\n", [pp(T), pp_loc(T)]) || T <- Types]]); +pp_error({event_0_to_3_indexed_values, Constr}) -> + io_lib:format("The event constructor ~s has too many indexed values (max 3)\n", [Constr]); +pp_error({event_0_to_1_string_values, Constr}) -> + io_lib:format("The event constructor ~s has too many string values (max 1)\n", [Constr]); +pp_error({repeated_constructor, Cs}) -> + io_lib:format("Variant types must have distinct constructor names\n~s", + [[ io_lib:format("~s (at ~s)\n", [pp_typed(" - ", C, T), pp_loc(C)]) || {C, T} <- Cs ]]); +pp_error({bad_named_argument, [], Name}) -> + io_lib:format("Named argument ~s (at ~s) supplied to function expecting no named arguments.\n", + [pp(Name), pp_loc(Name)]); +pp_error({bad_named_argument, Args, Name}) -> + io_lib:format("Named argument ~s (at ~s) is not one of the expected named arguments\n~s", + [pp(Name), pp_loc(Name), + [ io_lib:format("~s\n", [pp_typed(" - ", Arg, Type)]) + || {named_arg_t, _, Arg, Type, _} <- Args ]]); +pp_error({unsolved_named_argument_constraint, #named_argument_constraint{name = Name, type = Type}}) -> + io_lib:format("Named argument ~s (at ~s) supplied to function with unknown named arguments.\n", + [pp_typed("", Name, Type), pp_loc(Name)]); +pp_error({reserved_entrypoint, Name, Def}) -> + io_lib:format("The name '~s' is reserved and cannot be used for a\ntop-level contract function (at ~s).\n", + [Name, pp_loc(Def)]); +pp_error({duplicate_definition, Name, Locs}) -> + io_lib:format("Duplicate definitions of ~s at\n~s", + [Name, [ [" - ", pp_loc(L), "\n"] || L <- Locs ]]); +pp_error(Err) -> + io_lib:format("Unknown error: ~p\n", [Err]). + +pp_when({todo, What}) -> io_lib:format("[TODO] ~p\n", [What]); +pp_when({check_typesig, Name, Inferred, Given}) -> + io_lib:format("when checking the definition of ~s\n" + " inferred type: ~s\n" + " given type: ~s\n", + [Name, pp(instantiate(Inferred)), pp(instantiate(Given))]); +pp_when({infer_app, Fun, Args, Inferred0, ArgTypes0}) -> + Inferred = instantiate(Inferred0), + ArgTypes = instantiate(ArgTypes0), + io_lib:format("when checking the application at ~s of\n" + "~s\n" + "to arguments\n~s", + [pp_loc(Fun), + pp_typed(" ", Fun, Inferred), + [ [pp_typed(" ", Arg, ArgT), "\n"] + || {Arg, ArgT} <- lists:zip(Args, ArgTypes) ] ]); +pp_when({field_constraint, FieldType0, InferredType0, Fld}) -> + FieldType = instantiate(FieldType0), + InferredType = instantiate(InferredType0), + case Fld of + {field, _Ann, LV, Id, E} -> + io_lib:format("when checking the assignment of the field\n~s (at ~s)\nto the old value ~s and the new value\n~s\n", + [pp_typed(" ", {lvalue, [], LV}, FieldType), + pp_loc(Fld), + pp(Id), + pp_typed(" ", E, InferredType)]); + {field, _Ann, LV, E} -> + io_lib:format("when checking the assignment of the field\n~s (at ~s)\nto the value\n~s\n", + [pp_typed(" ", {lvalue, [], LV}, FieldType), + pp_loc(Fld), + pp_typed(" ", E, InferredType)]); + {proj, _Ann, _Rec, _Fld} -> + io_lib:format("when checking the record projection at ~s\n~s\nagainst the expected type\n~s\n", + [pp_loc(Fld), + pp_typed(" ", Fld, FieldType), + pp_type(" ", InferredType)]) + end; +pp_when({record_constraint, RecType0, InferredType0, Fld}) -> + RecType = instantiate(RecType0), + InferredType = instantiate(InferredType0), + case Fld of + {field, _Ann, _LV, _Id, _E} -> + io_lib:format("when checking that the record type\n~s\n~s\n" + "matches the expected type\n~s\n", + [pp_type(" ", RecType), + pp_why_record(Fld), + pp_type(" ", InferredType)]); + {field, _Ann, _LV, _E} -> + io_lib:format("when checking that the record type\n~s\n~s\n" + "matches the expected type\n~s\n", + [pp_type(" ", RecType), + pp_why_record(Fld), + pp_type(" ", InferredType)]); + {proj, _Ann, Rec, _FldName} -> + io_lib:format("when checking that the expression\n~s (at ~s)\nhas type\n~s\n~s\n", + [pp_typed(" ", Rec, InferredType), + pp_loc(Rec), + pp_type(" ", RecType), + pp_why_record(Fld)]) + end; +pp_when({if_branches, Then, ThenType0, Else, ElseType0}) -> + {ThenType, ElseType} = instantiate({ThenType0, ElseType0}), + Branches = [ {Then, ThenType} | [ {B, ElseType} || B <- if_branches(Else) ] ], + io_lib:format("when comparing the types of the if-branches\n" + "~s", [ [ io_lib:format("~s (at ~s)\n", [pp_typed(" - ", B, BType), pp_loc(B)]) + || {B, BType} <- Branches ] ]); +pp_when({case_pat, Pat, PatType0, ExprType0}) -> + {PatType, ExprType} = instantiate({PatType0, ExprType0}), + io_lib:format("when checking the type of the pattern at ~s\n~s\n" + "against the expected type\n~s\n", + [pp_loc(Pat), pp_typed(" ", Pat, PatType), + pp_type(" ", ExprType)]); +pp_when({check_expr, Expr, Inferred0, Expected0}) -> + {Inferred, Expected} = instantiate({Inferred0, Expected0}), + io_lib:format("when checking the type of the expression at ~s\n~s\n" + "against the expected type\n~s\n", + [pp_loc(Expr), pp_typed(" ", Expr, Inferred), + pp_type(" ", Expected)]); +pp_when(unknown) -> "". + +-spec pp_why_record(why_record()) -> iolist(). +pp_why_record(Fld = {field, _Ann, LV, _Id, _E}) -> + io_lib:format("arising from an assignment of the field ~s (at ~s)", + [pp_expr("", {lvalue, [], LV}), + pp_loc(Fld)]); +pp_why_record(Fld = {field, _Ann, LV, _E}) -> + io_lib:format("arising from an assignment of the field ~s (at ~s)", + [pp_expr("", {lvalue, [], LV}), + pp_loc(Fld)]); +pp_why_record({proj, _Ann, Rec, FldName}) -> + io_lib:format("arising from the projection of the field ~s (at ~s)", + [pp(FldName), + pp_loc(Rec)]). + + +if_branches(If = {'if', Ann, _, Then, Else}) -> + case proplists:get_value(format, Ann) of + elif -> [Then | if_branches(Else)]; + _ -> [If] + end; +if_branches(E) -> [E]. + +pp_typed(Label, E, T = {type_sig, _, _, _, _}) -> pp_typed(Label, E, typesig_to_fun_t(T)); +pp_typed(Label, {typed, _, Expr, _}, Type) -> + pp_typed(Label, Expr, Type); +pp_typed(Label, Expr, Type) -> + pp_expr(Label, {typed, [], Expr, Type}). + +pp_expr(Label, Expr) -> + prettypr:format(prettypr:beside(prettypr:text(Label), aeso_pretty:expr(Expr, [show_generated]))). + +pp_type(Label, Type) -> + prettypr:format(prettypr:beside(prettypr:text(Label), aeso_pretty:type(Type, [show_generated]))). + +line_number(T) -> aeso_syntax:get_ann(line, T, 0). +column_number(T) -> aeso_syntax:get_ann(col, T, 0). + +loc(T) -> + {line_number(T), column_number(T)}. + +pp_loc(T) -> + {Line, Col} = loc(T), + case {Line, Col} of + {0, 0} -> "(builtin location)"; + _ -> io_lib:format("line ~p, column ~p", [Line, Col]) + end. + +pp(T = {type_sig, _, _, _, _}) -> + pp(typesig_to_fun_t(T)); +pp([]) -> + ""; +pp([T]) -> + pp(T); +pp([T|Ts]) -> + [pp(T), ", "|pp(Ts)]; +pp({id, _, Name}) -> + Name; +pp({qid, _, Name}) -> + string:join(Name, "."); +pp({con, _, Name}) -> + Name; +pp({uvar, _, Ref}) -> + %% Show some unique representation + ["?u" | integer_to_list(erlang:phash2(Ref, 16384)) ]; +pp({tvar, _, Name}) -> + Name; +pp({tuple_t, _, Cpts}) -> + ["(", pp(Cpts), ")"]; +pp({app_t, _, T, []}) -> + pp(T); +pp({app_t, _, {id, _, Name}, Args}) -> + [Name, "(", pp(Args), ")"]; +pp({named_arg_t, _, Name, Type, Default}) -> + [pp(Name), " : ", pp(Type), " = ", pp(Default)]; +pp({fun_t, _, Named = {uvar, _, _}, As, B}) -> + ["(", pp(Named), " | ", pp(As), ") => ", pp(B)]; +pp({fun_t, _, Named, As, B}) when is_list(Named) -> + ["(", pp(Named ++ As), ") => ", pp(B)]. + +%% -- Pre-type checking desugaring ------------------------------------------- + +%% Desugars nested record/map updates as follows: +%% { x.y = v1, x.z @ z = f(z) } becomes { x @ __x = __x { y = v1, z @ z = f(z) } } +%% { [k1].x = v1, [k2].y = v2 } becomes { [k1] @ __x = __x { x = v1 }, [k2] @ __x = __x { y = v2 } } +%% There's no comparison of k1 and k2 to group the updates if they are equal. +desugar({record, Ann, Rec, Updates}) -> + {record, Ann, Rec, desugar_updates(Updates)}; +desugar({map, Ann, Map, Updates}) -> + {map, Ann, Map, desugar_updates(Updates)}; +desugar([H|T]) -> + [desugar(H) | desugar(T)]; +desugar(T) when is_tuple(T) -> + list_to_tuple(desugar(tuple_to_list(T))); +desugar(X) -> X. + +desugar_updates([]) -> []; +desugar_updates([Upd | Updates]) -> + {Key, MakeField, Rest} = update_key(Upd), + {More, Updates1} = updates_key(Key, Updates), + %% Check conflicts + case length([ [] || [] <- [Rest | More] ]) of + N when N > 1 -> error({conflicting_updates_for_field, Upd, Key}); + _ -> ok + end, + [MakeField(lists:append([Rest | More])) | desugar_updates(Updates1)]. + +%% TODO: refactor representation to make this not horrible +update_key(Fld = {field, _, [Elim], _}) -> + {elim_key(Elim), fun(_) -> Fld end, []}; +update_key(Fld = {field, _, [Elim], _, _}) -> + {elim_key(Elim), fun(_) -> Fld end, []}; +update_key({field, Ann, [P = {proj, _, {id, _, Name}} | Rest], Value}) -> + {Name, fun(Flds) -> {field, Ann, [P], {id, [], "__x"}, + desugar(map_or_record(Ann, {id, [], "__x"}, Flds))} + end, [{field, Ann, Rest, Value}]}; +update_key({field, Ann, [P = {proj, _, {id, _, Name}} | Rest], Id, Value}) -> + {Name, fun(Flds) -> {field, Ann, [P], {id, [], "__x"}, + desugar(map_or_record(Ann, {id, [], "__x"}, Flds))} + end, [{field, Ann, Rest, Id, Value}]}; +update_key({field, Ann, [K = {map_get, _, _} | Rest], Value}) -> + {map_key, fun(Flds) -> {field, Ann, [K], {id, [], "__x"}, + desugar(map_or_record(Ann, {id, [], "__x"}, Flds))} + end, [{field, Ann, Rest, Value}]}; +update_key({field, Ann, [K = {map_get, _, _, _} | Rest], Value}) -> + {map_key, fun(Flds) -> {field, Ann, [K], {id, [], "__x"}, + desugar(map_or_record(Ann, {id, [], "__x"}, Flds))} + end, [{field, Ann, Rest, Value}]}; +update_key({field, Ann, [K = {map_get, _, _, _} | Rest], Id, Value}) -> + {map_key, fun(Flds) -> {field, Ann, [K], {id, [], "__x"}, + desugar(map_or_record(Ann, {id, [], "__x"}, Flds))} + end, [{field, Ann, Rest, Id, Value}]}; +update_key({field, Ann, [K = {map_get, _, _} | Rest], Id, Value}) -> + {map_key, fun(Flds) -> {field, Ann, [K], {id, [], "__x"}, + desugar(map_or_record(Ann, {id, [], "__x"}, Flds))} + end, [{field, Ann, Rest, Id, Value}]}. + +map_or_record(Ann, Val, Flds = [Fld | _]) -> + Kind = case element(3, Fld) of + [{proj, _, _} | _] -> record; + [{map_get, _, _} | _] -> map; + [{map_get, _, _, _} | _] -> map + end, + {Kind, Ann, Val, Flds}. + +elim_key({proj, _, {id, _, Name}}) -> Name; +elim_key({map_get, _, _, _}) -> map_key; %% no grouping on map keys (yet) +elim_key({map_get, _, _}) -> map_key. + +updates_key(map_key, Updates) -> {[], Updates}; +updates_key(Name, Updates) -> + Xs = [ {Upd, Name1 == Name, Rest} + || Upd <- Updates, + {Name1, _, Rest} <- [update_key(Upd)] ], + Updates1 = [ Upd || {Upd, false, _} <- Xs ], + More = [ Rest || {_, true, Rest} <- Xs ], + {More, Updates1}. diff --git a/src/aeso_ast_to_icode.erl b/src/aeso_ast_to_icode.erl new file mode 100644 index 0000000..629e700 --- /dev/null +++ b/src/aeso_ast_to_icode.erl @@ -0,0 +1,711 @@ +%%%------------------------------------------------------------------- +%%% @author Happi (Erik Stenman) +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc +%%% Compiler from Aeterinty Sophia language to the Aeternity VM, aevm. +%%% @end +%%% Created : 21 Dec 2017 +%%% +%%%------------------------------------------------------------------- +-module(aeso_ast_to_icode). + +-export([ast_typerep/1, ast_typerep/2, type_value/1, + convert_typed/2, prim_call/5]). + +-include_lib("aebytecode/include/aeb_opcodes.hrl"). +-include("aeso_icode.hrl"). + +-spec convert_typed(aeso_syntax:ast(), list()) -> aeso_icode:icode(). +convert_typed(TypedTree, Options) -> + code(TypedTree, aeso_icode:new(Options)). + +code([{contract, _Attribs, {con, _, Name}, Code}|Rest], Icode) -> + NewIcode = contract_to_icode(Code, + aeso_icode:set_name(Name, Icode)), + code(Rest, NewIcode); +code([], Icode) -> + add_default_init_function(add_builtins(Icode)). + +%% Generate error on correct format. + +gen_error(Error) -> + error({code_errors, [Error]}). + +%% Create default init function (only if state is unit). +add_default_init_function(Icode = #{functions := Funs, state_type := State}) -> + case lists:keymember("init", 1, Funs) of + true -> Icode; + false when State /= {tuple, []} -> gen_error(missing_init_function); + false -> + Type = {tuple, [typerep, {tuple, []}]}, + Value = #tuple{ cpts = [type_value({tuple, []}), {tuple, []}] }, + DefaultInit = {"init", [], [], Value, Type}, + Icode#{ functions => [DefaultInit | Funs] } + end. + +-spec contract_to_icode(aeso_syntax:ast(), aeso_icode:icode()) -> + aeso_icode:icode(). +contract_to_icode([{type_def, _Attrib, {id, _, Name}, Args, Def} | Rest], + Icode = #{ types := Types, constructors := Constructors }) -> + TypeDef = make_type_def(Args, Def, Icode), + NewConstructors = + case Def of + {variant_t, Cons} -> + Tags = lists:seq(0, length(Cons) - 1), + GetName = fun({constr_t, _, {con, _, C}, _}) -> C end, + maps:from_list([ {GetName(Con), Tag} || {Tag, Con} <- lists:zip(Tags, Cons) ]); + _ -> #{} + end, + Icode1 = Icode#{ types := Types#{ Name => TypeDef }, + constructors := maps:merge(Constructors, NewConstructors) }, + Icode2 = case Name of + "state" when Args == [] -> Icode1#{ state_type => ast_typerep(Def, Icode) }; + "state" -> gen_error(state_type_cannot_be_parameterized); + "event" when Args == [] -> Icode1#{ event_type => Def }; + "event" -> gen_error(event_type_cannot_be_parameterized); + _ -> Icode1 + end, + contract_to_icode(Rest, Icode2); +contract_to_icode([{letfun, Attrib, Name, Args, _What, Body={typed,_,_,T}}|Rest], Icode) -> + FunAttrs = [ stateful || proplists:get_value(stateful, Attrib, false) ] ++ + [ private || proplists:get_value(private, Attrib, false) orelse + proplists:get_value(internal, Attrib, false) ], + %% TODO: Handle types + FunName = ast_id(Name), + %% TODO: push funname to env + FunArgs = ast_args(Args, [], Icode), + %% TODO: push args to env + {FunBody, TypeRep} = + case FunName of + "init" -> + %% Pair the initial state with a typerep for the state (TODO: until we have the state type in some contract metadata) + #{ state_type := StateType } = Icode, + {#tuple{ cpts = [type_value(StateType), ast_body(Body, Icode)] }, + {tuple, [typerep, ast_typerep(T, Icode)]}}; + _ -> {ast_body(Body, Icode), ast_typerep(T, Icode)} + end, + NewIcode = ast_fun_to_icode(FunName, FunAttrs, FunArgs, FunBody, TypeRep, Icode), + contract_to_icode(Rest, NewIcode); +contract_to_icode([{letrec,_,Defs}|Rest], Icode) -> + %% OBS! This code ignores the letrec structure of the source, + %% because the back end treats ALL declarations as recursive! We + %% need to decide whether to (a) modify the back end to respect + %% the letrec structure, or (b) (preferably) modify the front end + %% just to parse a list of (mutually recursive) definitions. + contract_to_icode(Defs++Rest, Icode); +contract_to_icode([], Icode) -> Icode; +contract_to_icode(Code, Icode) -> + lager:debug("Unhandled code ~p~n",[Code]), + Icode. + +ast_id({id, _, Id}) -> Id. + +ast_args([{arg, _, Name, Type}|Rest], Acc, Icode) -> + ast_args(Rest, [{ast_id(Name), ast_type(Type, Icode)}| Acc], Icode); +ast_args([], Acc, _Icode) -> lists:reverse(Acc). + +ast_type(T, Icode) -> + ast_typerep(T, Icode). + +-define(id_app(Fun, Args, ArgTypes, OutType), + {app, _, {typed, _, {id, _, Fun}, {fun_t, _, _, ArgTypes, OutType}}, Args}). + +-define(qid_app(Fun, Args, ArgTypes, OutType), + {app, _, {typed, _, {qid, _, Fun}, {fun_t, _, _, ArgTypes, OutType}}, Args}). + +-define(oracle_t(Q, R), {app_t, _, {id, _, "oracle"}, [Q, R]}). +-define(query_t(Q, R), {app_t, _, {id, _, "oracle_query"}, [Q, R]}). +-define(option_t(A), {app_t, _, {id, _, "option"}, [A]}). +-define(map_t(K, V), {app_t, _, {id, _, "map"}, [K, V]}). + +ast_body(?qid_app(["Chain","spend"], [To, Amount], _, _), Icode) -> + prim_call(?PRIM_CALL_SPEND, ast_body(Amount, Icode), [ast_body(To, Icode)], [word], {tuple, []}); + +ast_body(?qid_app(["Chain","event"], [Event], _, _), Icode) -> + aeso_builtins:check_event_type(Icode), + builtin_call({event, maps:get(event_type, Icode)}, [ast_body(Event, Icode)]); + +%% Chain environment +ast_body(?qid_app(["Chain", "balance"], [Address], _, _), Icode) -> + #prim_balance{ address = ast_body(Address, Icode) }; +ast_body(?qid_app(["Chain", "block_hash"], [Height], _, _), Icode) -> + #prim_block_hash{ height = ast_body(Height, Icode) }; +ast_body(?qid_app(["Call", "gas_left"], [], _, _), _Icode) -> + prim_gas_left; +ast_body({qid, _, ["Contract", "address"]}, _Icode) -> prim_contract_address; +ast_body({qid, _, ["Contract", "balance"]}, _Icode) -> #prim_balance{ address = prim_contract_address }; +ast_body({qid, _, ["Call", "origin"]}, _Icode) -> prim_call_origin; +ast_body({qid, _, ["Call", "caller"]}, _Icode) -> prim_caller; +ast_body({qid, _, ["Call", "value"]}, _Icode) -> prim_call_value; +ast_body({qid, _, ["Call", "gas_price"]}, _Icode) -> prim_gas_price; +ast_body({qid, _, ["Chain", "coinbase"]}, _Icode) -> prim_coinbase; +ast_body({qid, _, ["Chain", "timestamp"]}, _Icode) -> prim_timestamp; +ast_body({qid, _, ["Chain", "block_height"]}, _Icode) -> prim_block_height; +ast_body({qid, _, ["Chain", "difficulty"]}, _Icode) -> prim_difficulty; +ast_body({qid, _, ["Chain", "gas_limit"]}, _Icode) -> prim_gas_limit; +%% TODO: eta expand! +ast_body({qid, _, ["Chain", "balance"]}, _Icode) -> + gen_error({underapplied_primitive, 'Chain.balance'}); +ast_body({qid, _, ["Chain", "block_hash"]}, _Icode) -> + gen_error({underapplied_primitive, 'Chain.block_hash'}); +ast_body({qid, _, ["Chain", "spend"]}, _Icode) -> + gen_error({underapplied_primitive, 'Chain.spend'}); + +%% State +ast_body({id, _, "state"}, _Icode) -> prim_state; +ast_body(?id_app("put", [NewState], _, _), Icode) -> + #prim_put{ state = ast_body(NewState, Icode) }; +ast_body({id, _, "put"}, _Icode) -> + gen_error({underapplied_primitive, put}); %% TODO: eta + +%% Abort +ast_body(?id_app("abort", [String], _, _), Icode) -> + #funcall{ function = #var_ref{ name = {builtin, abort} }, + args = [ast_body(String, Icode)] }; + +%% Oracles +ast_body(?qid_app(["Oracle", "register"], Args, _, ?oracle_t(QType, RType)), Icode) -> + {Sign, [Acct, QFee, TTL]} = get_signature_arg(Args), + prim_call(?PRIM_CALL_ORACLE_REGISTER, #integer{value = 0}, + [ast_body(Acct, Icode), ast_body(Sign, Icode), ast_body(QFee, Icode), ast_body(TTL, Icode), + ast_type_value(QType, Icode), ast_type_value(RType, Icode)], + [word, sign_t(), word, ttl_t(Icode), typerep, typerep], word); + +ast_body(?qid_app(["Oracle", "query_fee"], [Oracle], _, _), Icode) -> + prim_call(?PRIM_CALL_ORACLE_QUERY_FEE, #integer{value = 0}, + [ast_body(Oracle, Icode)], [word], word); + +ast_body(?qid_app(["Oracle", "query"], [Oracle, Q, QFee, QTTL, RTTL], [_, QType, _, _, _], _), Icode) -> + prim_call(?PRIM_CALL_ORACLE_QUERY, ast_body(QFee, Icode), + [ast_body(Oracle, Icode), ast_body(Q, Icode), ast_body(QTTL, Icode), ast_body(RTTL, Icode)], + [word, ast_type(QType, Icode), ttl_t(Icode), ttl_t(Icode)], word); + +ast_body(?qid_app(["Oracle", "extend"], Args, _, _), Icode) -> + {Sign, [Oracle, TTL]} = get_signature_arg(Args), + prim_call(?PRIM_CALL_ORACLE_EXTEND, #integer{value = 0}, + [ast_body(Oracle, Icode), ast_body(Sign, Icode), ast_body(TTL, Icode)], + [word, sign_t(), ttl_t(Icode)], {tuple, []}); + +ast_body(?qid_app(["Oracle", "respond"], Args, [_, _, RType], _), Icode) -> + {Sign, [Oracle, Query, R]} = get_signature_arg(Args), + prim_call(?PRIM_CALL_ORACLE_RESPOND, #integer{value = 0}, + [ast_body(Oracle, Icode), ast_body(Query, Icode), ast_body(Sign, Icode), ast_body(R, Icode)], + [word, word, sign_t(), ast_type(RType, Icode)], {tuple, []}); + +ast_body(?qid_app(["Oracle", "get_question"], [Oracle, Q], [_, ?query_t(QType, _)], _), Icode) -> + prim_call(?PRIM_CALL_ORACLE_GET_QUESTION, #integer{value = 0}, + [ast_body(Oracle, Icode), ast_body(Q, Icode)], [word, word], ast_type(QType, Icode)); + +ast_body(?qid_app(["Oracle", "get_answer"], [Oracle, Q], [_, ?query_t(_, RType)], _), Icode) -> + prim_call(?PRIM_CALL_ORACLE_GET_ANSWER, #integer{value = 0}, + [ast_body(Oracle, Icode), ast_body(Q, Icode)], [word, word], aeso_icode:option_typerep(ast_type(RType, Icode))); + +ast_body({qid, _, ["Oracle", "register"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.register'}); +ast_body({qid, _, ["Oracle", "query"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.query'}); +ast_body({qid, _, ["Oracle", "extend"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.extend'}); +ast_body({qid, _, ["Oracle", "respond"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.respond'}); +ast_body({qid, _, ["Oracle", "query_fee"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.query_fee'}); +ast_body({qid, _, ["Oracle", "get_answer"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.get_answer'}); +ast_body({qid, _, ["Oracle", "get_question"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.get_question'}); + +%% Name service +ast_body(?qid_app(["AENS", "resolve"], [Name, Key], _, ?option_t(Type)), Icode) -> + case is_monomorphic(Type) of + true -> + case ast_type(Type, Icode) of + T when T == word; T == string -> ok; + _ -> gen_error({invalid_result_type, 'AENS.resolve', Type}) + end, + prim_call(?PRIM_CALL_AENS_RESOLVE, #integer{value = 0}, + [ast_body(Name, Icode), ast_body(Key, Icode), ast_type_value(Type, Icode)], + [string, string, typerep], aeso_icode:option_typerep(ast_type(Type, Icode))); + false -> + gen_error({unresolved_result_type, 'AENS.resolve', Type}) + end; + +ast_body(?qid_app(["AENS", "preclaim"], Args, _, _), Icode) -> + {Sign, [Addr, CHash]} = get_signature_arg(Args), + prim_call(?PRIM_CALL_AENS_PRECLAIM, #integer{value = 0}, + [ast_body(Addr, Icode), ast_body(CHash, Icode), ast_body(Sign, Icode)], + [word, word, sign_t()], {tuple, []}); + +ast_body(?qid_app(["AENS", "claim"], Args, _, _), Icode) -> + {Sign, [Addr, Name, Salt]} = get_signature_arg(Args), + prim_call(?PRIM_CALL_AENS_CLAIM, #integer{value = 0}, + [ast_body(Addr, Icode), ast_body(Name, Icode), ast_body(Salt, Icode), ast_body(Sign, Icode)], + [word, string, word, sign_t()], {tuple, []}); + +ast_body(?qid_app(["AENS", "transfer"], Args, _, _), Icode) -> + {Sign, [FromAddr, ToAddr, NameHash]} = get_signature_arg(Args), + prim_call(?PRIM_CALL_AENS_TRANSFER, #integer{value = 0}, + [ast_body(FromAddr, Icode), ast_body(ToAddr, Icode), ast_body(NameHash, Icode), ast_body(Sign, Icode)], + [word, word, word, sign_t()], {tuple, []}); + +ast_body(?qid_app(["AENS", "revoke"], Args, _, _), Icode) -> + {Sign, [Addr, NameHash]} = get_signature_arg(Args), + prim_call(?PRIM_CALL_AENS_REVOKE, #integer{value = 0}, + [ast_body(Addr, Icode), ast_body(NameHash, Icode), ast_body(Sign, Icode)], + [word, word, sign_t()], {tuple, []}); + +ast_body({qid, _, ["AENS", "resolve"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.resolve'}); +ast_body({qid, _, ["AENS", "preclaim"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.preclaim'}); +ast_body({qid, _, ["AENS", "claim"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.claim'}); +ast_body({qid, _, ["AENS", "transfer"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.transfer'}); +ast_body({qid, _, ["AENS", "revoke"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.revoke'}); + +%% Maps + +%% -- map lookup m[k] +ast_body({map_get, _, Map, Key}, Icode) -> + {_, ValType} = check_monomorphic_map(Map, Icode), + Fun = {map_get, ast_typerep(ValType, Icode)}, + builtin_call(Fun, [ast_body(Map, Icode), ast_body(Key, Icode)]); +%% -- map lookup_default m[k = v] +ast_body({map_get, _, Map, Key, Val}, Icode) -> + {_, ValType} = check_monomorphic_map(Map, Icode), + Fun = {map_lookup_default, ast_typerep(ValType, Icode)}, + builtin_call(Fun, [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Val, Icode)]); + +%% -- lookup functions +ast_body(?qid_app(["Map", "lookup"], [Key, Map], _, _), Icode) -> + map_get(Key, Map, Icode); +ast_body(?qid_app(["Map", "lookup_default"], [Key, Map, Val], _, _), Icode) -> + {_, ValType} = check_monomorphic_map(Map, Icode), + Fun = {map_lookup_default, ast_typerep(ValType, Icode)}, + builtin_call(Fun, [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Val, Icode)]); +ast_body(?qid_app(["Map", "member"], [Key, Map], _, _), Icode) -> + builtin_call(map_member, [ast_body(Map, Icode), ast_body(Key, Icode)]); +ast_body(?qid_app(["Map", "size"], [Map], _, _), Icode) -> + builtin_call(map_size, [ast_body(Map, Icode)]); +ast_body(?qid_app(["Map", "delete"], [Key, Map], _, _), Icode) -> + map_del(Key, Map, Icode); + +%% -- map conversion to/from list +ast_body(App = ?qid_app(["Map", "from_list"], [List], _, MapType), Icode) -> + Ann = aeso_syntax:get_ann(App), + {KeyType, ValType} = check_monomorphic_map(Ann, MapType, Icode), + builtin_call(map_from_list, [ast_body(List, Icode), map_empty(KeyType, ValType, Icode)]); + +ast_body(?qid_app(["Map", "to_list"], [Map], _, _), Icode) -> + map_tolist(Map, Icode); + +ast_body({qid, _, ["Map", "from_list"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.from_list'}); +%% ast_body({qid, _, ["Map", "to_list"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.to_list'}); +ast_body({qid, _, ["Map", "lookup"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.lookup'}); +ast_body({qid, _, ["Map", "lookup_default"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.lookup_default'}); +ast_body({qid, _, ["Map", "member"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.member'}); + +%% -- map construction { k1 = v1, k2 = v2 } +ast_body({typed, Ann, {map, _, KVs}, MapType}, Icode) -> + {KeyType, ValType} = check_monomorphic_map(Ann, MapType, Icode), + lists:foldr(fun({K, V}, Map) -> + builtin_call(map_put, [Map, ast_body(K, Icode), ast_body(V, Icode)]) + end, map_empty(KeyType, ValType, Icode), KVs); + +%% -- map update m { [k] = v } or m { [k] @ x = f(x) } or m { [k = v] @ x = f(x) } +ast_body({map, _, Map, []}, Icode) -> ast_body(Map, Icode); +ast_body({map, _, Map, [Upd]}, Icode) -> + case Upd of + {field, _, [{map_get, _, Key}], Val} -> + map_put(Key, Val, Map, Icode); + {field_upd, _, [{map_get, _, Key}], ValFun} -> + map_upd(Key, ValFun, Map, Icode); + {field_upd, _, [{map_get, _, Key, Val}], ValFun} -> + map_upd(Key, Val, ValFun, Map, Icode) + end; +ast_body({map, Ann, Map, [Upd | Upds]}, Icode) -> + ast_body({map, Ann, {map, Ann, Map, [Upd]}, Upds}, Icode); + +%% Strings +%% -- String length +ast_body(?qid_app(["String", "length"], [String], _, _), Icode) -> + #funcall{ function = #var_ref{ name = {builtin, string_length} }, + args = [ast_body(String, Icode)] }; + +%% -- String concat +ast_body(?qid_app(["String", "concat"], [String1, String2], _, _), Icode) -> + #funcall{ function = #var_ref{ name = {builtin, string_concat} }, + args = [ast_body(String1, Icode), ast_body(String2, Icode)] }; + +%% -- String hash (sha3) +ast_body(?qid_app(["String", "sha3"], [String], _, _), Icode) -> + #unop{ op = 'sha3', rand = ast_body(String, Icode) }; + +%% -- Conversion +ast_body(?qid_app(["Int", "to_str"], [Int], _, _), Icode) -> + builtin_call(int_to_str, [ast_body(Int, Icode)]); + +ast_body(?qid_app(["Address", "to_str"], [Addr], _, _), Icode) -> + builtin_call(addr_to_str, [ast_body(Addr, Icode)]); + +%% Other terms +ast_body({id, _, Name}, _Icode) -> + %% TODO Look up id in env + #var_ref{name = Name}; +ast_body({bool, _, Bool}, _Icode) -> %BOOL as ints + Value = if Bool -> 1 ; true -> 0 end, + #integer{value = Value}; +ast_body({int, _, Value}, _Icode) -> + #integer{value = Value}; +ast_body({hash, _, Hash}, _Icode) -> + case Hash of + <> -> %% address + #integer{value = Value}; + <> -> %% signature + #tuple{cpts = [#integer{value = Hi}, + #integer{value = Lo}]} + end; +ast_body({string,_,Bin}, _Icode) -> + Cpts = [size(Bin) | aeso_memory:binary_to_words(Bin)], + #tuple{cpts = [#integer{value=X} || X <- Cpts]}; +ast_body({tuple,_,Args}, Icode) -> + #tuple{cpts = [ast_body(A, Icode) || A <- Args]}; +ast_body({list,_,Args}, Icode) -> + #list{elems = [ast_body(A, Icode) || A <- Args]}; +%% Typed contract calls +ast_body({proj, _, {typed, _, Addr, {con, _, _}}, {id, _, "address"}}, Icode) -> + ast_body(Addr, Icode); %% Values of contract types _are_ addresses. +ast_body({app, _, {typed, _, {proj, _, {typed, _, Addr, {con, _, Contract}}, {id, _, FunName}}, + {fun_t, _, NamedT, ArgsT, OutT}}, Args0}, Icode) -> + NamedArgs = [Arg || Arg = {named_arg, _, _, _} <- Args0], + Args = Args0 -- NamedArgs, + ArgOpts = [ {Name, ast_body(Value, Icode)} || {named_arg, _, {id, _, Name}, Value} <- NamedArgs ], + Defaults = [ {Name, ast_body(Default, Icode)} || {named_arg_t, _, {id, _, Name}, _, Default} <- NamedT ], + %% TODO: eta expand + length(Args) /= length(ArgsT) andalso + gen_error({underapplied_contract_call, + string:join([Contract, FunName], ".")}), + ArgsI = [ ast_body(Arg, Icode) || Arg <- Args ], + ArgType = ast_typerep({tuple_t, [], ArgsT}), + Gas = proplists:get_value("gas", ArgOpts ++ Defaults), + Value = proplists:get_value("value", ArgOpts ++ Defaults), + OutType = ast_typerep(OutT, Icode), + <> = aeso_abi:function_type_hash(list_to_binary(FunName), ArgType, OutType), + %% The function is represented by its type hash (which includes the name) + Fun = #integer{value = TypeHash}, + #prim_call_contract{ + address = ast_body(Addr, Icode), + gas = Gas, + value = Value, + arg = #tuple{cpts = [Fun, #tuple{ cpts = ArgsI }]}, + %% The type check is implicitly done by using the type hash as the + %% entrypoint on the callee side. + type_hash= #integer{value = 0} + }; +ast_body({proj, _, {typed, _, _, {con, _, Contract}}, {id, _, FunName}}, _Icode) -> + gen_error({underapplied_contract_call, + string:join([Contract, FunName], ".")}); + +ast_body({con, _, Name}, Icode) -> + Tag = aeso_icode:get_constructor_tag(Name, Icode), + #tuple{cpts = [#integer{value = Tag}]}; +ast_body({app, _, {typed, _, {con, _, Name}, _}, Args}, Icode) -> + Tag = aeso_icode:get_constructor_tag(Name, Icode), + #tuple{cpts = [#integer{value = Tag} | [ ast_body(Arg, Icode) || Arg <- Args ]]}; +ast_body({app,As,Fun,Args}, Icode) -> + case aeso_syntax:get_ann(format, As) of + infix -> + {Op, _} = Fun, + [A, B] = Args, + ast_binop(Op, As, A, B, Icode); + prefix -> + {Op, _} = Fun, + [A] = Args, + #unop{op = Op, rand = ast_body(A, Icode)}; + _ -> + #funcall{function=ast_body(Fun, Icode), + args=[ast_body(A, Icode) || A <- Args]} + end; +ast_body({'if',_,Dec,Then,Else}, Icode) -> + #ifte{decision = ast_body(Dec, Icode) + ,then = ast_body(Then, Icode) + ,else = ast_body(Else, Icode)}; +ast_body({switch,_,A,Cases}, Icode) -> + %% let's assume the parser has already ensured that only valid + %% patterns appear in cases. + #switch{expr=ast_body(A, Icode), + cases=[{ast_body(Pat, Icode),ast_body(Body, Icode)} + || {'case',_,Pat,Body} <- Cases]}; +ast_body({block,As,[{letval,_,Pat,_,E}|Rest]}, Icode) -> + #switch{expr=ast_body(E, Icode), + cases=[{ast_body(Pat, Icode),ast_body({block,As,Rest}, Icode)}]}; +ast_body({block,_,[]}, _Icode) -> + #tuple{cpts=[]}; +ast_body({block,_,[E]}, Icode) -> + ast_body(E, Icode); +ast_body({block,As,[E|Rest]}, Icode) -> + #switch{expr=ast_body(E, Icode), + cases=[{#var_ref{name="_"},ast_body({block,As,Rest}, Icode)}]}; +ast_body({lam,_,Args,Body}, Icode) -> + #lambda{args=[#arg{name = ast_id(P), type = ast_type(T, Icode)} || {arg,_,P,T} <- Args], + body=ast_body(Body, Icode)}; +ast_body({typed,_,{record,Attrs,Fields},{record_t,DefFields}}, Icode) -> + %% Compile as a tuple with the fields in the order they appear in the definition. + NamedField = fun({field, _, [{proj, _, {id, _, Name}}], E}) -> {Name, E} end, + NamedFields = lists:map(NamedField, Fields), + #tuple{cpts = + [case proplists:get_value(Name,NamedFields) of + undefined -> + lager:debug("~p not in ~p\n", [Name, NamedFields]), + Line = aeso_syntax:get_ann(line, Attrs), + #missing_field{format = "Missing field in record: ~s (on line ~p)\n", + args = [Name,Line]}; + E -> + ast_body(E, Icode) + end + || {field_t,_,{id,_,Name},_} <- DefFields]}; +ast_body({typed,_,{record,Attrs,_Fields},T}, _Icode) -> + gen_error({record_has_bad_type,Attrs,T}); +ast_body({proj,_,{typed,_,Record,{record_t,Fields}},{id,_,FieldName}}, Icode) -> + [Index] = [I + || {I,{field_t,_,{id,_,Name},_}} <- + lists:zip(lists:seq(1,length(Fields)),Fields), + Name==FieldName], + #binop{op = '!', left = #integer{value = 32*(Index-1)}, right = ast_body(Record, Icode)}; +ast_body({record, Attrs, {typed, _, Record, RecType={record_t, Fields}}, Update}, Icode) -> + UpdatedName = fun({field, _, [{proj, _, {id, _, Name}}], _}) -> Name; + ({field_upd, _, [{proj, _, {id, _, Name}}], _}) -> Name + end, + UpdatedNames = lists:map(UpdatedName, Update), + Rec = {typed, Attrs, {id, Attrs, "_record"}, RecType}, + CompileUpdate = + fun(Fld={field, _, _, _}) -> Fld; + ({field_upd, Ann, LV=[{proj, Ann1, P}], Fun}) -> + {field, Ann, LV, {app, Ann, Fun, [{proj, Ann1, Rec, P}]}} + end, + + #switch{expr=ast_body(Record, Icode), + cases=[{#var_ref{name = "_record"}, + ast_body({typed, Attrs, + {record, Attrs, + lists:map(CompileUpdate, Update) ++ + [{field, Attrs, [{proj, Attrs, {id, Attrs, Name}}], + {proj, Attrs, Rec, {id, Attrs, Name}}} + || {field_t, _, {id, _, Name}, _} <- Fields, + not lists:member(Name, UpdatedNames)]}, + RecType}, Icode)} + ]}; +ast_body({typed, _, Body, _}, Icode) -> + ast_body(Body, Icode). + +ast_binop(Op, Ann, {typed, _, A, Type}, B, Icode) + when Op == '=='; Op == '!='; + Op == '<'; Op == '>'; + Op == '<='; Op == '=<'; Op == '>=' -> + Monomorphic = is_monomorphic(Type), + case ast_typerep(Type, Icode) of + _ when not Monomorphic -> + gen_error({cant_compare_polymorphic_type, Ann, Op, Type}); + word -> #binop{op = Op, left = ast_body(A, Icode), right = ast_body(B, Icode)}; + string -> + Neg = case Op of + '==' -> fun(X) -> X end; + '!=' -> fun(X) -> #unop{ op = '!', rand = X } end; + _ -> gen_error({cant_compare, Ann, Op, Type}) + end, + Neg(#funcall{ function = #var_ref{name = {builtin, str_equal}}, + args = [ast_body(A, Icode), ast_body(B, Icode)] }); + _ -> gen_error({cant_compare, Ann, Op, Type}) + end; +ast_binop('++', _, A, B, Icode) -> + #funcall{ function = #var_ref{ name = {builtin, list_concat} }, + args = [ast_body(A, Icode), ast_body(B, Icode)] }; +ast_binop('bsl', _, A, B, Icode) -> + #binop{op = '*', left = ast_body(A, Icode), + right = #binop{op = '^', left = {integer, 2}, right = ast_body(B, Icode)}}; +ast_binop('bsr', _, A, B, Icode) -> + #binop{op = 'div', left = ast_body(A, Icode), + right = #binop{op = '^', left = {integer, 2}, right = ast_body(B, Icode)}}; +ast_binop(Op, _, A, B, Icode) -> + #binop{op = Op, left = ast_body(A, Icode), right = ast_body(B, Icode)}. + +check_monomorphic_map({typed, Ann, _, MapType}, Icode) -> + check_monomorphic_map(Ann, MapType, Icode). + +check_monomorphic_map(Ann, Type = ?map_t(KeyType, ValType), Icode) -> + case is_monomorphic(KeyType) of + true -> + case has_maps(ast_type(KeyType, Icode)) of + false -> {KeyType, ValType}; + true -> gen_error({cant_use_map_as_map_keys, Ann, Type}) + end; + false -> gen_error({cant_compile_map_with_polymorphic_keys, Ann, Type}) + end. + +map_empty(KeyType, ValType, Icode) -> + prim_call(?PRIM_CALL_MAP_EMPTY, #integer{value = 0}, + [ast_type_value(KeyType, Icode), + ast_type_value(ValType, Icode)], + [typerep, typerep], word). + +map_get(Key, Map = {typed, Ann, _, MapType}, Icode) -> + {_KeyType, ValType} = check_monomorphic_map(Ann, MapType, Icode), + builtin_call({map_lookup, ast_type(ValType, Icode)}, [ast_body(Map, Icode), ast_body(Key, Icode)]). + +map_put(Key, Val, Map, Icode) -> + builtin_call(map_put, [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Val, Icode)]). + +map_del(Key, Map, Icode) -> + prim_call(?PRIM_CALL_MAP_DELETE, #integer{value = 0}, + [ast_body(Map, Icode), ast_body(Key, Icode)], + [word, word], word). + +map_tolist(Map, Icode) -> + {KeyType, ValType} = check_monomorphic_map(Map, Icode), + prim_call(?PRIM_CALL_MAP_TOLIST, #integer{value = 0}, + [ast_body(Map, Icode)], + [word], {list, {tuple, [ast_type(KeyType, Icode), ast_type(ValType, Icode)]}}). + +map_upd(Key, ValFun, Map = {typed, Ann, _, MapType}, Icode) -> + {_, ValType} = check_monomorphic_map(Ann, MapType, Icode), + FunName = {map_upd, ast_type(ValType, Icode)}, + Args = [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(ValFun, Icode)], + builtin_call(FunName, Args). + +map_upd(Key, Default, ValFun, Map = {typed, Ann, _, MapType}, Icode) -> + {_, ValType} = check_monomorphic_map(Ann, MapType, Icode), + FunName = {map_upd_default, ast_type(ValType, Icode)}, + Args = [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Default, Icode), ast_body(ValFun, Icode)], + builtin_call(FunName, Args). + +is_monomorphic({tvar, _, _}) -> false; +is_monomorphic([H|T]) -> + is_monomorphic(H) andalso is_monomorphic(T); +is_monomorphic(T) when is_tuple(T) -> + is_monomorphic(tuple_to_list(T)); +is_monomorphic(_) -> true. + +%% Implemented as a contract call to the contract with address 0. +prim_call(Prim, Amount, Args, ArgTypes, OutType) -> + TypeHash = + case aeb_primops:op_needs_type_check(Prim) of + true -> + PrimBin = binary:encode_unsigned(Prim), + ArgType = {tuple, ArgTypes}, + <> = aeso_abi:function_type_hash(PrimBin, ArgType, OutType), + TH; + false -> + 0 + end, + #prim_call_contract{ gas = prim_gas_left, + address = #integer{ value = ?PRIM_CALLS_CONTRACT }, + value = Amount, + arg = #tuple{cpts = [#integer{ value = Prim }| Args]}, + type_hash= #integer{value = TypeHash} + }. + +make_type_def(Args, Def, Icode = #{ type_vars := TypeEnv }) -> + TVars = [ X || {tvar, _, X} <- Args ], + fun(Types) -> + TypeEnv1 = maps:from_list(lists:zip(TVars, Types)), + ast_typerep(Def, Icode#{ type_vars := maps:merge(TypeEnv, TypeEnv1) }) + end. + +-spec ast_typerep(aeso_syntax:type()) -> aeso_sophia:type(). +ast_typerep(Type) -> ast_typerep(Type, aeso_icode:new([])). + +ast_typerep({id, _, Name}, Icode) -> + lookup_type_id(Name, [], Icode); +ast_typerep({qid, _, Name}, Icode) -> + lookup_type_id(Name, [], Icode); +ast_typerep({con, _, _}, _) -> + word; %% Contract type +ast_typerep({app_t, _, {id, _, Name}, Args}, Icode) -> + ArgReps = [ ast_typerep(Arg, Icode) || Arg <- Args ], + lookup_type_id(Name, ArgReps, Icode); +ast_typerep({tvar,_,A}, #{ type_vars := TypeVars }) -> + case maps:get(A, TypeVars, undefined) of + undefined -> word; %% We serialize type variables just as addresses in the originating VM. + Type -> Type + end; +ast_typerep({tuple_t,_,Cpts}, Icode) -> + {tuple, [ast_typerep(C, Icode) || C<-Cpts]}; +ast_typerep({record_t,Fields}, Icode) -> + {tuple, [ begin + {field_t, _, _, T} = Field, + ast_typerep(T, Icode) + end || Field <- Fields]}; +ast_typerep({fun_t,_,_,_,_}, _Icode) -> + function; +ast_typerep({alias_t, T}, Icode) -> ast_typerep(T, Icode); +ast_typerep({variant_t, Cons}, Icode) -> + {variant, [ begin + {constr_t, _, _, Args} = Con, + [ ast_typerep(Arg, Icode) || Arg <- Args ] + end || Con <- Cons ]}. + +ttl_t(Icode) -> + ast_typerep({qid, [], ["Chain", "ttl"]}, Icode). + +sign_t() -> + {tuple, [word, word]}. + +get_signature_arg(Args0) -> + NamedArgs = [Arg || Arg = {named_arg, _, _, _} <- Args0], + Args = Args0 -- NamedArgs, + + DefaultVal = {tuple, [], [{int, [], 0}, {int, [], 0}]}, + Sig = + case NamedArgs of + [] -> DefaultVal; + [{named_arg, _, _, Val}] -> Val + end, + {Sig, Args}. + +lookup_type_id(Name, Args, #{ types := Types }) -> + case maps:get(Name, Types, undefined) of + undefined -> gen_error({undefined_type, Name}); + TDef -> TDef(Args) + end. + +ast_type_value(T, Icode) -> + type_value(ast_type(T, Icode)). + +type_value(word) -> + #tuple{ cpts = [#integer{ value = ?TYPEREP_WORD_TAG }] }; +type_value(string) -> + #tuple{ cpts = [#integer{ value = ?TYPEREP_STRING_TAG }] }; +type_value(typerep) -> + #tuple{ cpts = [#integer{ value = ?TYPEREP_TYPEREP_TAG }] }; +type_value({list, A}) -> + #tuple{ cpts = [#integer{ value = ?TYPEREP_LIST_TAG }, type_value(A)] }; +type_value({tuple, As}) -> + #tuple{ cpts = [#integer{ value = ?TYPEREP_TUPLE_TAG }, + #list{ elems = [ type_value(A) || A <- As ] }] }; +type_value({variant, Cs}) -> + #tuple{ cpts = [#integer{ value = ?TYPEREP_VARIANT_TAG }, + #list{ elems = [ #list{ elems = [ type_value(A) || A <- As ] } || As <- Cs ] }] }; +type_value({map, K, V}) -> + #tuple{ cpts = [#integer{ value = ?TYPEREP_MAP_TAG }, + type_value(K), type_value(V)] }. + +%% As abort is a built-in in the future it will be illegal to for +%% users to define abort. For the time being strip away all user +%% defined abort functions. + +ast_fun_to_icode("abort", _Atts, _Args, _Body, _TypeRep, Icode) -> + %% Strip away all user defined abort functions. + Icode; +ast_fun_to_icode(Name, Attrs, Args, Body, TypeRep, #{functions := Funs} = Icode) -> + NewFuns = [{Name, Attrs, Args, Body, TypeRep}| Funs], + aeso_icode:set_functions(NewFuns, Icode). + +has_maps({map, _, _}) -> true; +has_maps(word) -> false; +has_maps(string) -> false; +has_maps(typerep) -> false; +has_maps({list, T}) -> has_maps(T); +has_maps({tuple, Ts}) -> lists:any(fun has_maps/1, Ts); +has_maps({variant, Cs}) -> lists:any(fun has_maps/1, lists:append(Cs)). + +%% ------------------------------------------------------------------- +%% Builtins +%% ------------------------------------------------------------------- + +builtin_call(Builtin, Args) -> + #funcall{ function = #var_ref{ name = {builtin, Builtin} }, + args = Args }. + +add_builtins(Icode = #{functions := Funs}) -> + Builtins = aeso_builtins:used_builtins(Funs), + Icode#{functions := [ aeso_builtins:builtin_function(B) || B <- Builtins ] ++ Funs}. diff --git a/src/aeso_builtins.erl b/src/aeso_builtins.erl new file mode 100644 index 0000000..4d328fc --- /dev/null +++ b/src/aeso_builtins.erl @@ -0,0 +1,510 @@ +%%%------------------------------------------------------------------- +%%% @copyright (C) 2018, Aeternity Anstalt +%%% @doc +%%% Compiler builtin functions for Aeterinty Sophia language. +%%% @end +%%% Created : 20 Dec 2018 +%%% +%%%------------------------------------------------------------------- + +-module(aeso_builtins). + +-export([ builtin_function/1 + , check_event_type/1 + , used_builtins/1 ]). + +-import(aeso_ast_to_icode, [prim_call/5]). + +-include_lib("aebytecode/include/aeb_opcodes.hrl"). +-include("aeso_icode.hrl"). + +used_builtins(#funcall{ function = #var_ref{ name = {builtin, Builtin} }, args = Args }) -> + lists:umerge(dep_closure([Builtin]), used_builtins(Args)); +used_builtins([H|T]) -> + lists:umerge(used_builtins(H), used_builtins(T)); +used_builtins(T) when is_tuple(T) -> + used_builtins(tuple_to_list(T)); +used_builtins(M) when is_map(M) -> + used_builtins(maps:to_list(M)); +used_builtins(_) -> []. + +builtin_deps(Builtin) -> + lists:usort(builtin_deps1(Builtin)). + +builtin_deps1({map_lookup_default, Type}) -> [{map_lookup, Type}]; +builtin_deps1({map_get, Type}) -> [{map_lookup, Type}]; +builtin_deps1(map_member) -> [{map_lookup, word}]; +builtin_deps1({map_upd, Type}) -> [{map_get, Type}, map_put]; +builtin_deps1({map_upd_default, Type}) -> [{map_lookup_default, Type}, map_put]; +builtin_deps1(map_from_list) -> [map_put]; +builtin_deps1(str_equal) -> [str_equal_p]; +builtin_deps1(string_concat) -> [string_concat_inner1, string_concat_inner2]; +builtin_deps1(int_to_str) -> [int_to_str_, int_digits]; +builtin_deps1(addr_to_str) -> [base58_int, string_concat]; +builtin_deps1(base58_int) -> [base58_int_encode, base58_int_pad, string_reverse, string_concat]; +builtin_deps1(base58_int_encode) -> [base58_int_encode_, base58_tab]; +builtin_deps1(string_reverse) -> [string_reverse_]; +builtin_deps1(_) -> []. + +dep_closure(Deps) -> + case lists:umerge(lists:map(fun builtin_deps/1, Deps)) of + [] -> Deps; + Deps1 -> lists:umerge(Deps, dep_closure(Deps1)) + end. + +%% Helper functions/macros +v(X) when is_atom(X) -> v(atom_to_list(X)); +v(X) when is_list(X) -> #var_ref{name = X}. + +option_none() -> {tuple, [{integer, 0}]}. +option_some(X) -> {tuple, [{integer, 1}, X]}. + +-define(call(Fun, Args), #funcall{ function = #var_ref{ name = {builtin, Fun} }, args = Args }). +-define(I(X), {integer, X}). +-define(V(X), v(X)). +-define(A(Op), aeb_opcodes:mnemonic(Op)). +-define(LET(Var, Expr, Body), {switch, Expr, [{v(Var), Body}]}). +-define(DEREF(Var, Ptr, Body), {switch, v(Ptr), [{{tuple, [v(Var)]}, Body}]}). +-define(NXT(Ptr), op('+', Ptr, 32)). +-define(NEG(A), op('/', A, {unop, '-', {integer, 1}})). +-define(BYTE(Ix, Word), op('byte', Ix, Word)). + +-define(EQ(A, B), op('==', A, B)). +-define(LT(A, B), op('<', A, B)). +-define(GT(A, B), op('>', A, B)). +-define(ADD(A, B), op('+', A, B)). +-define(SUB(A, B), op('-', A, B)). +-define(MUL(A, B), op('*', A, B)). +-define(DIV(A, B), op('div', A, B)). +-define(MOD(A, B), op('mod', A, B)). +-define(EXP(A, B), op('^', A, B)). +-define(AND(A, B), op('&&', A, B)). + +-define(BSL(X, B), ?MUL(X, ?EXP(2, ?MUL(B, 8)))). +-define(BSR(X, B), ?DIV(X, ?EXP(2, ?MUL(B, 8)))). + +op(Op, A, B) -> {binop, Op, operand(A), operand(B)}. + +operand(A) when is_atom(A) -> v(A); +operand(I) when is_integer(I) -> {integer, I}; +operand(T) -> T. + +str_to_icode(String) when is_list(String) -> + str_to_icode(list_to_binary(String)); +str_to_icode(BinStr) -> + Cpts = [size(BinStr) | aeso_memory:binary_to_words(BinStr)], + #tuple{ cpts = [ #integer{value = X} || X <- Cpts ] }. + +check_event_type(Icode) -> + case maps:get(event_type, Icode) of + {variant_t, Cons} -> + check_event_type(Cons, Icode); + _ -> + error({event_should_be_variant_type}) + end. + +check_event_type(Evts, Icode) -> + [ check_event_type(Name, T, Icode) + || {constr_t, _, {con, _, Name}, Types} <- Evts, T <- Types ]. + +check_event_type(EvtName, Type, Icode) -> + io:format("~p: ~p??\n", [EvtName, Type]), + io:format("=> ~p\n", [aeso_ast_to_icode:ast_typerep(Type, Icode)]), + VMType = + try + aeso_ast_to_icode:ast_typerep(Type, Icode) + catch _:_ -> + error({EvtName, could_not_resolve_type, Type}) + end, + case aeso_syntax:get_ann(indexed, Type, false) of + true when VMType == word -> ok; + false when VMType == string -> ok; + true -> error({EvtName, indexed_field_should_be_word, is, VMType}); + false -> error({EvtName, payload_should_be_string, is, VMType}) + end. + +%% Event primitive (dependent on Event type) +%% +%% We need to switch on the event and prepare the correct #event for icode_to_asm +%% NOTE: we assume all errors are already checked! +builtin_function(Builtin = {event, EventT}) -> + A = fun(X) -> aeb_opcodes:mnemonic(X) end, + VIx = fun(Ix) -> v(lists:concat(["v", Ix])) end, + ArgPats = fun(Ts) -> [ VIx(Ix) || Ix <- lists:seq(0, length(Ts) - 1) ] end, + IsIndexed = fun(T) -> aeso_syntax:get_ann(indexed, T, false) end, + Payload = %% Should put data ptr, length on stack. + fun([]) -> {inline_asm, [A(?PUSH1), 0, A(?PUSH1), 0]}; + ([V]) -> {seq, [V, {inline_asm, [A(?DUP1), A(?MLOAD), %% length, ptr + A(?SWAP1), A(?PUSH1), 32, A(?ADD)]}]} %% ptr+32, length + end, + Clause = + fun(_Tag, {con, _, Con}, Types) -> + Indexed = [ Var || {Var, Type} <- lists:zip(ArgPats(Types), Types), + IsIndexed(Type) ], + EvtIndex = {unop, 'sha3', str_to_icode(Con)}, + {event, lists:reverse(Indexed) ++ [EvtIndex], Payload(ArgPats(Types) -- Indexed)} + end, + Pat = fun(Tag, Types) -> {tuple, [{integer, Tag} | ArgPats(Types)]} end, + + {variant_t, Cons} = EventT, + Tags = lists:seq(0, length(Cons) - 1), + + {{builtin, Builtin}, [private], + [{"e", event}], + {switch, v(e), + [{Pat(Tag, Types), Clause(Tag, Con, Types)} + || {Tag, {constr_t, _, Con, Types}} <- lists:zip(Tags, Cons) ]}, + {tuple, []}}; + +%% Abort primitive. +builtin_function(abort) -> + A = fun(X) -> aeb_opcodes:mnemonic(X) end, + {{builtin, abort}, [private], + [{"s", string}], + {inline_asm, [A(?PUSH1),0, %% Push a dummy 0 for the first arg + A(?REVERT)]}, %% Stack: 0,Ptr + {tuple,[]}}; + +%% Map primitives +builtin_function(Builtin = {map_lookup, Type}) -> + Ret = aeso_icode:option_typerep(Type), + {{builtin, Builtin}, [private], + [{"m", word}, {"k", word}], + prim_call(?PRIM_CALL_MAP_GET, #integer{value = 0}, + [#var_ref{name = "m"}, #var_ref{name = "k"}], + [word, word], Ret), + Ret}; + +builtin_function(Builtin = map_put) -> + %% We don't need the types for put. + {{builtin, Builtin}, [private], + [{"m", word}, {"k", word}, {"v", word}], + prim_call(?PRIM_CALL_MAP_PUT, #integer{value = 0}, + [v(m), v(k), v(v)], + [word, word, word], word), + word}; + +builtin_function(Builtin = map_delete) -> + {{builtin, Builtin}, [private], + [{"m", word}, {"k", word}], + prim_call(?PRIM_CALL_MAP_DELETE, #integer{value = 0}, + [v(m), v(k)], + [word, word], word), + word}; + +builtin_function(Builtin = map_size) -> + Name = {builtin, Builtin}, + {Name, [private], [{"m", word}], + prim_call(?PRIM_CALL_MAP_SIZE, #integer{value = 0}, + [v(m)], [word], word), + word}; + +%% Map builtins +builtin_function(Builtin = {map_get, Type}) -> + %% function map_get(m, k) = + %% switch(map_lookup(m, k)) + %% Some(v) => v + {{builtin, Builtin}, [private], + [{"m", word}, {"k", word}], + {switch, ?call({map_lookup, Type}, [v(m), v(k)]), + [{option_some(v(v)), v(v)}]}, + Type}; + +builtin_function(Builtin = {map_lookup_default, Type}) -> + %% function map_lookup_default(m, k, default) = + %% switch(map_lookup(m, k)) + %% None => default + %% Some(v) => v + {{builtin, Builtin}, [private], + [{"m", word}, {"k", word}, {"default", Type}], + {switch, ?call({map_lookup, Type}, [v(m), v(k)]), + [{option_none(), v(default)}, + {option_some(v(v)), v(v)}]}, + Type}; + +builtin_function(Builtin = map_member) -> + %% function map_member(m, k) : bool = + %% switch(Map.lookup(m, k)) + %% None => false + %% _ => true + {{builtin, Builtin}, [private], + [{"m", word}, {"k", word}], + {switch, ?call({map_lookup, word}, [v(m), v(k)]), + [{option_none(), {integer, 0}}, + {{var_ref, "_"}, {integer, 1}}]}, + word}; + +builtin_function(Builtin = {map_upd, Type}) -> + %% function map_upd(map, key, fun) = + %% map_put(map, key, fun(map_get(map, key))) + {{builtin, Builtin}, [private], + [{"map", word}, {"key", word}, {"valfun", word}], + ?call(map_put, + [v(map), v(key), + #funcall{ function = v(valfun), + args = [?call({map_get, Type}, [v(map), v(key)])] }]), + word}; + +builtin_function(Builtin = {map_upd_default, Type}) -> + %% function map_upd(map, key, val, fun) = + %% map_put(map, key, fun(map_lookup_default(map, key, val))) + {{builtin, Builtin}, [private], + [{"map", word}, {"key", word}, {"val", word}, {"valfun", word}], + ?call(map_put, + [v(map), v(key), + #funcall{ function = v(valfun), + args = [?call({map_lookup_default, Type}, [v(map), v(key), v(val)])] }]), + word}; + +builtin_function(Builtin = map_from_list) -> + %% function map_from_list(xs, acc) = + %% switch(xs) + %% [] => acc + %% (k, v) :: xs => map_from_list(xs, acc { [k] = v }) + {{builtin, Builtin}, [private], + [{"xs", {list, {tuple, [word, word]}}}, {"acc", word}], + {switch, v(xs), + [{{list, []}, v(acc)}, + {{binop, '::', {tuple, [v(k), v(v)]}, v(ys)}, + ?call(map_from_list, + [v(ys), ?call(map_put, [v(acc), v(k), v(v)])])}]}, + word}; + +%% list_concat +%% +%% Concatenates two lists. +builtin_function(list_concat) -> + {{builtin, list_concat}, [private], + [{"l1", {list, word}}, {"l2", {list, word}}], + {switch, v(l1), + [{{list, []}, v(l2)}, + {{binop, '::', v(hd), v(tl)}, + {binop, '::', v(hd), ?call(list_concat, [v(tl), v(l2)])}} + ] + }, + word}; + +builtin_function(string_length) -> + %% function length(str) = + %% switch(str) + %% {n} -> n // (ab)use the representation + {{builtin, string_length}, [private], + [{"s", string}], + ?DEREF(n, s, ?V(n)), + word}; + +%% str_concat - concatenate two strings +%% +%% Unless the second string is the empty string, a new string is created at the +%% top of the Heap and the address to it is returned. The tricky bit is when +%% the words from the second string has to be shifted to fit next to the first +%% string. +builtin_function(string_concat) -> + {{builtin, string_concat}, [private], + [{"s1", string}, {"s2", string}], + ?DEREF(n1, s1, + ?DEREF(n2, s2, + {ifte, ?EQ(n2, 0), + ?V(s1), %% Second string is empty return first string + ?LET(ret, {inline_asm, [?A(?MSIZE)]}, + {seq, [?ADD(n1, n2), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, %% Store total len + ?call(string_concat_inner1, [?V(n1), ?NXT(s1), ?V(n2), ?NXT(s2)]), + {inline_asm, [?A(?POP)]}, %% Discard fun ret val + ?V(ret) %% Put the actual return value + ]})} + )), + word}; + +builtin_function(string_concat_inner1) -> + %% Copy all whole words from the first string, and set up for word fusion + %% Special case when the length of the first string is divisible by 32. + {{builtin, string_concat_inner1}, [private], + [{"n1", word}, {"p1", pointer}, {"n2", word}, {"p2", pointer}], + ?DEREF(w1, p1, + {ifte, ?GT(n1, 32), + {seq, [?V(w1), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + ?call(string_concat_inner1, [?SUB(n1, 32), ?NXT(p1), ?V(n2), ?V(p2)])]}, + {ifte, ?EQ(n1, 0), + ?call(string_concat_inner2, [?I(32), ?I(0), ?V(n2), ?V(p2)]), + ?call(string_concat_inner2, [?SUB(32, n1), ?V(w1), ?V(n2), ?V(p2)])} + }), + word}; + +builtin_function(string_concat_inner2) -> + %% Current "work in progess" word 'x', has 'o' bytes that are "free" - fill them from + %% words of the second string. + {{builtin, string_concat_inner2}, [private], + [{"o", word}, {"x", word}, {"n2", word}, {"p2", pointer}], + {ifte, ?LT(n2, 1), + {seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE), ?A(?MSIZE)]}]}, %% Use MSIZE as dummy return value + ?DEREF(w2, p2, + {ifte, ?GT(n2, o), + {seq, [?ADD(x, ?BSR(w2, ?SUB(32, o))), + {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + ?call(string_concat_inner2, + [?V(o), ?BSL(w2, o), ?SUB(n2, 32), ?NXT(p2)]) + ]}, + {seq, [?ADD(x, ?BSR(w2, ?SUB(32, o))), + {inline_asm, [?A(?MSIZE), ?A(?MSTORE), ?A(?MSIZE)]}]} %% Use MSIZE as dummy return value + }) + }, + word}; + +builtin_function(str_equal_p) -> + %% function str_equal_p(n, p1, p2) = + %% if(n =< 0) true + %% else + %% let w1 = *p1 + %% let w2 = *p2 + %% w1 == w2 && str_equal_p(n - 32, p1 + 32, p2 + 32) + {{builtin, str_equal_p}, [private], + [{"n", word}, {"p1", pointer}, {"p2", pointer}], + {ifte, ?LT(n, 1), + ?I(1), + ?DEREF(w1, p1, + ?DEREF(w2, p2, + ?AND(?EQ(w1, w2), + ?call(str_equal_p, [?SUB(n, 32), ?NXT(p1), ?NXT(p2)]))))}, + word}; + +builtin_function(str_equal) -> + %% function str_equal(s1, s2) = + %% let n1 = length(s1) + %% let n2 = length(s2) + %% n1 == n2 && str_equal_p(n1, s1 + 32, s2 + 32) + {{builtin, str_equal}, [private], + [{"s1", string}, {"s2", string}], + ?DEREF(n1, s1, + ?DEREF(n2, s2, + ?AND(?EQ(n1, n2), ?call(str_equal_p, [?V(n1), ?NXT(s1), ?NXT(s2)])) + )), + word}; + +builtin_function(int_to_str) -> + {{builtin, int_to_str}, [private], + [{"i0", word}], + {switch, {ifte, ?LT(i0, 0), + {tuple, [?I(2), ?NEG(i0), ?BSL(45, 31)]}, + {tuple, [?I(1), ?V(i0), ?I(0)]}}, + [{{tuple, [v(off), v(i), v(x)]}, + ?LET(ret, {inline_asm, [?A(?MSIZE)]}, + ?LET(n, ?call(int_digits, [?DIV(i, 10), ?I(0)]), + ?LET(fac, ?EXP(10, n), + {seq, [?ADD(n, off), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, %% Store str len + ?call(int_to_str_, + [?MOD(i, fac), ?ADD(x, ?BSL(?ADD(48, ?DIV(i, fac)), ?SUB(32, off))), ?DIV(fac, 10), ?V(off)]), + {inline_asm, [?A(?POP)]}, ?V(ret)]} + )))}]}, + word}; + +builtin_function(int_to_str_) -> + {{builtin, int_to_str_}, [private], + [{"x", word}, {"y", word}, {"fac", word}, {"n", word}], + {ifte, ?EQ(fac, 0), + {seq, [?V(y), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, ?V(n)]}, + {ifte, ?EQ(?MOD(n, 32), 0), + %% We've filled a word, write it and start on new word + {seq, [?V(y), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + ?call(int_to_str_, + [?MOD(x, fac), ?BSL(?ADD(48, ?DIV(x, fac)), 31), + ?DIV(fac, 10), ?I(1)])]}, + ?call(int_to_str_, + [?MOD(x, fac), ?ADD(y, ?BSL(?ADD(48, ?DIV(x, fac)), ?SUB(31, n))), + ?DIV(fac, 10), ?ADD(n, 1)])} + }, + word}; + +builtin_function(int_digits) -> + {{builtin, int_digits}, [private], + [{"x", word}, {"n", word}], + {ifte, ?EQ(x, 0), ?V(n), ?call(int_digits, [?DIV(x, 10), ?ADD(n, 1)])}, + word}; + +builtin_function(base58_tab) -> + Fst32 = 22252025330403739761829862310514590177935513752035045390683118730099851483225, + Lst26 = 40880219588527126470443504235291962205031881694701834176631306799289575931904, + {{builtin, base58_tab}, [private], + [{"ix", word}], + {ifte, ?LT(ix, 32), + ?BYTE(ix, Fst32), + ?BYTE(?SUB(ix, 32), Lst26) + }, word}; + +builtin_function(base58_int) -> + {{builtin, base58_int}, [private], + [{"w", word}], + ?LET(str0, ?call(base58_int_encode, [?V(w)]), + ?LET(str1, ?call(base58_int_pad, [?V(w), ?I(0), ?I(0)]), + ?LET(str2, ?call(string_concat, [?V(str0), ?V(str1)]), + ?call(string_reverse, [?V(str2)]) + ))), + word}; + +builtin_function(string_reverse) -> + {{builtin, string_reverse}, [private], + [{"s", string}], + ?DEREF(n, s, + ?LET(ret, {inline_asm, [?A(?MSIZE)]}, + {seq, [?V(n), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + ?call(string_reverse_, [?NXT(s), ?I(0), ?I(31), ?SUB(?V(n), 1)]), + {inline_asm, [?A(?POP)]}, ?V(ret)]})), + word}; + +builtin_function(string_reverse_) -> + {{builtin, string_reverse_}, [private], + [{"p", pointer}, {"x", word}, {"i1", word}, {"i2", word}], + {ifte, ?LT(i2, 0), + {seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE), ?A(?MSIZE)]}]}, + ?LET(p1, ?ADD(p, ?MUL(?DIV(i2, 32), 32)), + ?DEREF(w, p1, + ?LET(b, ?BYTE(?MOD(i2, 32), w), + {ifte, ?LT(i1, 0), + {seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + ?call(string_reverse_, + [?V(p), ?BSL(b, 31), ?I(30), ?SUB(i2, 1)])]}, + ?call(string_reverse_, + [?V(p), ?ADD(x, ?BSL(b, i1)), ?SUB(i1, 1), ?SUB(i2, 1)])})))}, + word}; + +builtin_function(base58_int_pad) -> + {{builtin, base58_int_pad}, [private], + [{"w", word}, {"i", word}, {"x", word}], + {ifte, ?GT(?BYTE(i, w), 0), + {seq, [?V(i), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + ?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + {inline_asm, [?A(?PUSH1), 64, ?A(?MSIZE), ?A(?SUB)]}]}, + ?call(base58_int_pad, [?V(w), ?ADD(i, 1), + ?ADD(x, ?BSL(49, ?SUB(31, i)))])}, + word}; + +builtin_function(base58_int_encode) -> + {{builtin, base58_int_encode}, [private], + [{"w", word}], + ?LET(ret, {inline_asm, [?A(?MSIZE), ?A(?PUSH1), 0, ?A(?MSIZE), ?A(?MSTORE)]}, %% write placeholder + ?LET(n, ?call(base58_int_encode_, [?V(w), ?I(0), ?I(0), ?I(31)]), + {seq, [?V(ret), {inline_asm, [?A(?DUP2), ?A(?SWAP1), ?A(?MSTORE)]}, + ?V(ret)]})), + word}; + +builtin_function(base58_int_encode_) -> + {{builtin, base58_int_encode_}, [private], + [{"w", word}, {"x", word}, {"n", word}, {"i", word}], + {ifte, ?EQ(w, 0), + {seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, ?V(n)]}, + {ifte, ?LT(i, 0), + {seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, + ?call(base58_int_encode_, + [?DIV(w, 58), ?BSL(?call(base58_tab, [?MOD(w, 58)]), 31), + ?ADD(n, 1), ?I(30)])]}, + ?call(base58_int_encode_, + [?DIV(w, 58), ?ADD(x, ?BSL(?call(base58_tab, [?MOD(w, 58)]), i)), + ?ADD(n, 1), ?SUB(i, 1)])}}, + word}; + + +builtin_function(addr_to_str) -> + {{builtin, addr_to_str}, [private], + [{"a", word}], + ?call(base58_int, [?V(a)]), + word}. + diff --git a/src/aeso_compiler.erl b/src/aeso_compiler.erl new file mode 100644 index 0000000..e132005 --- /dev/null +++ b/src/aeso_compiler.erl @@ -0,0 +1,259 @@ +%%%------------------------------------------------------------------- +%%% @author Happi (Erik Stenman) +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc +%%% Compiler from Aeterinty Sophia language to the Aeternity VM, aevm. +%%% @end +%%% Created : 12 Dec 2017 +%%%------------------------------------------------------------------- +-module(aeso_compiler). + +-export([ file/1 + , file/2 + , from_string/2 + , check_call/2 + , create_calldata/3 + , version/0 + , sophia_type_to_typerep/1 + ]). + +-include_lib("aebytecode/include/aeb_opcodes.hrl"). +-include("aeso_icode.hrl"). + + +-type option() :: pp_sophia_code | pp_ast | pp_icode | pp_assembler | + pp_bytecode. +-type options() :: [option()]. + +-export_type([ option/0 + , options/0 + ]). + +-define(COMPILER_VERSION_1, 1). +-define(COMPILER_VERSION_2, 2). + +-define(COMPILER_VERSION, ?COMPILER_VERSION_2). + +-spec version() -> pos_integer(). +version() -> + ?COMPILER_VERSION. + +-spec file(string()) -> map(). +file(Filename) -> + file(Filename, []). + +-spec file(string(), options()) -> map(). +file(Filename, Options) -> + C = read_contract(Filename), + from_string(C, Options). + +-spec from_string(string(), options()) -> map(). +from_string(ContractString, Options) -> + Ast = parse(ContractString, Options), + ok = pp_sophia_code(Ast, Options), + ok = pp_ast(Ast, Options), + TypedAst = aeso_ast_infer_types:infer(Ast, Options), + %% pp_types is handled inside aeso_ast_infer_types. + ok = pp_typed_ast(TypedAst, Options), + ICode = to_icode(TypedAst, Options), + TypeInfo = extract_type_info(ICode), + ok = pp_icode(ICode, Options), + Assembler = assemble(ICode, Options), + ok = pp_assembler(Assembler, Options), + ByteCodeList = to_bytecode(Assembler, Options), + ByteCode = << << B:8 >> || B <- ByteCodeList >>, + ok = pp_bytecode(ByteCode, Options), + #{byte_code => ByteCode, type_info => TypeInfo, + contract_source => ContractString, + compiler_version => version()}. + +-define(CALL_NAME, "__call"). + +%% Takes a string containing a contract with a declaration/prototype of a +%% function (foo, say) and a function __call() = foo(args) calling this +%% function. Returns the name of the called functions, typereps and Erlang +%% terms for the arguments. +-spec check_call(string(), options()) -> {ok, string(), {[Type], Type | any}, [term()]} | {error, term()} + when Type :: term(). +check_call(ContractString, Options) -> + Ast = parse(ContractString, Options), + ok = pp_sophia_code(Ast, Options), + ok = pp_ast(Ast, Options), + TypedAst = aeso_ast_infer_types:infer(Ast, [permissive_address_literals]), + {ok, {FunName, {fun_t, _, _, ArgTypes, RetType}}} = get_call_type(TypedAst), + ok = pp_typed_ast(TypedAst, Options), + Icode = to_icode(TypedAst, Options), + ArgVMTypes = [ aeso_ast_to_icode:ast_typerep(T, Icode) || T <- ArgTypes ], + RetVMType = case RetType of + {id, _, "_"} -> any; + _ -> aeso_ast_to_icode:ast_typerep(RetType, Icode) + end, + ok = pp_icode(Icode, Options), + #{ functions := Funs } = Icode, + ArgIcode = get_arg_icode(Funs), + try [ icode_to_term(T, Arg) || {T, Arg} <- lists:zip(ArgVMTypes, ArgIcode) ] of + ArgTerms -> + {ok, FunName, {ArgVMTypes, RetVMType}, ArgTerms} + catch throw:Err -> + {error, Err} + end. + +-spec create_calldata(map(), string(), string()) -> + {ok, aeso_sophia:heap(), aeso_sophia:type(), aeso_sophia:type()} + | {error, argument_syntax_error}. +create_calldata(Contract, "", CallCode) when is_map(Contract) -> + case check_call(CallCode, []) of + {ok, FunName, {ArgTypes, RetType}, Args} -> + aeso_abi:create_calldata(Contract, FunName, Args, ArgTypes, RetType); + {error, _} = Err -> Err + end; +create_calldata(Contract, Function, Argument) when is_map(Contract) -> + %% Slightly hacky shortcut to let you get away without writing the full + %% call contract code. + %% Function should be "foo : type", and + %% Argument should be "Arg1, Arg2, .., ArgN" (no parens) + case string:lexemes(Function, ": ") of + %% If function is a single word fallback to old calldata generation + [FunName] -> aeso_abi:old_create_calldata(Contract, FunName, Argument); + [FunName | _] -> + Args = lists:map(fun($\n) -> 32; (X) -> X end, Argument), %% newline to space + CallContract = lists:flatten( + [ "contract Call =\n" + , " function ", Function, "\n" + , " function __call() = ", FunName, "(", Args, ")" + ]), + create_calldata(Contract, "", CallContract) + end. + + +get_arg_icode(Funs) -> + [Args] = [ Args || {?CALL_NAME, _, _, {funcall, _, Args}, _} <- Funs ], + Args. + +get_call_type([{contract, _, _, Defs}]) -> + case [ {FunName, FunType} + || {letfun, _, {id, _, ?CALL_NAME}, [], _Ret, + {typed, _, + {app, _, + {typed, _, {id, _, FunName}, FunType}, _}, _}} <- Defs ] of + [Call] -> {ok, Call}; + [] -> {error, missing_call_function} + end; +get_call_type([_ | Contracts]) -> + %% The __call should be in the final contract + get_call_type(Contracts). + +%% Translate an icode value (error if not value) to an Erlang term that can be +%% consumed by aeso_heap:to_binary(). +icode_to_term(word, {integer, N}) -> N; +icode_to_term(string, {tuple, [{integer, Len} | Words]}) -> + <> = << <> || {integer, W} <- Words >>, + Str; +icode_to_term({list, T}, {list, Vs}) -> + [ icode_to_term(T, V) || V <- Vs ]; +icode_to_term({tuple, Ts}, {tuple, Vs}) -> + list_to_tuple(icodes_to_terms(Ts, Vs)); +icode_to_term({variant, Cs}, {tuple, [{integer, Tag} | Args]}) -> + Ts = lists:nth(Tag + 1, Cs), + {variant, Tag, icodes_to_terms(Ts, Args)}; +icode_to_term(T = {map, KT, VT}, M) -> + %% Maps are compiled to builtin and primop calls, so this gets a little hairy + case M of + {funcall, {var_ref, {builtin, map_put}}, [M1, K, V]} -> + Map = icode_to_term(T, M1), + Key = icode_to_term(KT, K), + Val = icode_to_term(VT, V), + Map#{ Key => Val }; + #prim_call_contract{ address = {integer, 0}, + arg = {tuple, [{integer, ?PRIM_CALL_MAP_EMPTY}, _, _]} } -> + #{}; + _ -> throw({todo, M}) + end; +icode_to_term(typerep, _) -> + throw({todo, typerep}); +icode_to_term(T, V) -> + throw({not_a_value, T, V}). + +icodes_to_terms(Ts, Vs) -> + [ icode_to_term(T, V) || {T, V} <- lists:zip(Ts, Vs) ]. + +parse(C,_Options) -> + parse_string(C). + +to_icode(TypedAst, Options) -> + aeso_ast_to_icode:convert_typed(TypedAst, Options). + +assemble(Icode, Options) -> + aeso_icode_to_asm:convert(Icode, Options). + + +to_bytecode(['COMMENT',_|Rest],_Options) -> + to_bytecode(Rest,_Options); +to_bytecode([Op|Rest], Options) -> + [aeb_opcodes:m_to_op(Op)|to_bytecode(Rest, Options)]; +to_bytecode([], _) -> []. + +extract_type_info(#{functions := Functions} =_Icode) -> + TypeInfo = [aeso_abi:function_type_info(list_to_binary(Name), Args, TypeRep) + || {Name, Attrs, Args,_Body, TypeRep} <- Functions, + not is_tuple(Name), + not lists:member(private, Attrs) + ], + lists:sort(TypeInfo). + +pp_sophia_code(C, Opts)-> pp(C, Opts, pp_sophia_code, fun(Code) -> + io:format("~s\n", [prettypr:format(aeso_pretty:decls(Code))]) + end). +pp_ast(C, Opts) -> pp(C, Opts, pp_ast, fun aeso_ast:pp/1). +pp_typed_ast(C, Opts)-> pp(C, Opts, pp_typed_ast, fun aeso_ast:pp_typed/1). +pp_icode(C, Opts) -> pp(C, Opts, pp_icode, fun aeso_icode:pp/1). +pp_assembler(C, Opts)-> pp(C, Opts, pp_assembler, fun aeb_asm:pp/1). +pp_bytecode(C, Opts) -> pp(C, Opts, pp_bytecode, fun aeb_disassemble:pp/1). + +pp(Code, Options, Option, PPFun) -> + case proplists:lookup(Option, Options) of + {Option, true} -> + PPFun(Code); + none -> + ok + end. + + +%% ------------------------------------------------------------------- +%% TODO: Tempoary parser hook below... + +sophia_type_to_typerep(String) -> + {ok, Ast} = aeso_parser:type(String), + try aeso_ast_to_icode:ast_typerep(Ast) of + Type -> {ok, Type} + catch _:_ -> {error, bad_type} + end. + +parse_string(Text) -> + %% Try and return something sensible here! + case aeso_parser:string(Text) of + %% Yay, it worked! + {ok, Contract} -> Contract; + %% Scan errors. + {error, {Pos, scan_error}} -> + parse_error(Pos, "scan error"); + {error, {Pos, scan_error_no_state}} -> + parse_error(Pos, "scan error"); + %% Parse errors. + {error, {Pos, parse_error, Error}} -> + parse_error(Pos, Error); + {error, {Pos, ambiguous_parse, As}} -> + ErrorString = io_lib:format("Ambiguous ~p", [As]), + parse_error(Pos, ErrorString) + end. + +parse_error({Line,Pos}, ErrorString) -> + Error = io_lib:format("line ~p, column ~p: ~s", [Line,Pos,ErrorString]), + error({parse_errors,[Error]}). + +read_contract(Name) -> + {ok, Bin} = file:read_file(filename:join(contract_path(), lists:concat([Name, ".aes"]))), + binary_to_list(Bin). + +contract_path() -> + "apps/aesophia/test/contracts". diff --git a/src/aeso_constants.erl b/src/aeso_constants.erl new file mode 100644 index 0000000..7475c2a --- /dev/null +++ b/src/aeso_constants.erl @@ -0,0 +1,42 @@ +-module(aeso_constants). + +-export([string/1, get_type/1]). + +string(Str) -> + case aeso_parser:string("let _ = " ++ Str) of + {ok, [{letval, _, _, _, E}]} -> {ok, E}; + {ok, Other} -> error({internal_error, should_be_letval, Other}); + Err -> Err + end. + +get_type(Str) -> + case aeso_parser:string("let _ = " ++ Str) of + {ok, [Ast]} -> + AstT = aeso_ast_infer_types:infer_constant(Ast), + T = ast_to_type(AstT), + {ok, T}; + {ok, Other} -> error({internal_error, should_be_letval, Other}); + Err -> Err + end. + +ast_to_type({id, _, T}) -> + T; +ast_to_type({tuple_t, _, []}) -> "()"; +ast_to_type({tuple_t, _, Ts}) -> + "(" ++ list_ast_to_type(Ts) ++ ")"; +ast_to_type({app_t,_, {id, _, "list"}, [T]}) -> + lists:flatten("list(" ++ ast_to_type(T) ++ ")"); +ast_to_type({app_t,_, {id, _, "option"}, [T]}) -> + lists:flatten("option(" ++ ast_to_type(T) ++ ")"). + +list_ast_to_type([T]) -> + ast_to_type(T); +list_ast_to_type([T|Ts]) -> + ast_to_type(T) + ++ ", " + ++ list_ast_to_type(Ts). + + + + + diff --git a/src/aeso_heap.erl b/src/aeso_heap.erl new file mode 100644 index 0000000..b437a68 --- /dev/null +++ b/src/aeso_heap.erl @@ -0,0 +1,301 @@ +-module(aeso_heap). + +-export([ to_binary/1 + , to_binary/2 + , from_heap/3 + , from_binary/2 + , from_binary/3 + , maps_with_next_id/1 + , set_next_id/2 + , heap_fragment/3 + , heap_value/3 + , heap_value/4 + , heap_value_pointer/1 + , heap_value_maps/1 + , heap_value_offset/1 + , heap_value_heap/1 + , heap_fragment_maps/1 + , heap_fragment_offset/1 + , heap_fragment_heap/1 + ]). + +-export_type([binary_value/0, heap_value/0, offset/0, heap_fragment/0]). + +-include("aeso_icode.hrl"). +-include_lib("aesophia/include/aeso_heap.hrl"). + +-type word() :: non_neg_integer(). +-type pointer() :: word(). +-opaque heap_fragment() :: #heap{}. +-type offset() :: non_neg_integer(). +-type binary_value() :: binary(). +-type heap_value() :: {pointer(), heap_fragment()}. + + +-spec maps_with_next_id(heap_fragment()) -> #maps{}. +%% Create just a maps value, don't keep rest of Heap +maps_with_next_id(#heap{maps = #maps{next_id = N}}) -> + #maps{ next_id = N }. + +-spec set_next_id(heap_fragment(), non_neg_integer()) -> heap_fragment(). +set_next_id(Heap, N) -> + Heap#heap{ maps = Heap#heap.maps#maps{ next_id = N } }. + +%% -- data type heap_fragment + +-spec heap_fragment(binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment(). +heap_fragment(Heap) -> + heap_fragment(#maps{ next_id = 0 }, 0, Heap). + +-spec heap_fragment(#maps{}, offset(), + binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment(). +heap_fragment(Maps, Offset, Heap) -> + #heap{maps = Maps, offset = Offset, heap = Heap}. + +-spec heap_fragment_maps(heap_fragment()) -> #maps{}. +heap_fragment_maps(#heap{maps = Maps}) -> + Maps. + +-spec heap_fragment_offset(heap_fragment()) -> offset(). +heap_fragment_offset(#heap{offset = Offs}) -> + Offs. + +-spec heap_fragment_heap(heap_fragment()) -> binary() | #{non_neg_integer() => non_neg_integer()}. +heap_fragment_heap(#heap{heap = Heap}) -> + Heap. + + +%% -- data type heap_value + +-spec heap_value(#maps{}, pointer(), + binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_value(). +heap_value(Maps, Ptr, Heap) -> + heap_value(Maps, Ptr, Heap, 0). + +-spec heap_value(#maps{}, pointer(), + binary() | #{non_neg_integer() => non_neg_integer()}, offset()) -> heap_value(). +heap_value(Maps, Ptr, Heap, Offs) -> + {Ptr, heap_fragment(Maps, Offs, Heap)}. + +-spec heap_value_pointer(heap_value()) -> pointer(). +heap_value_pointer({Ptr, _}) -> Ptr. + +-spec heap_value_maps(heap_value()) -> #maps{}. +heap_value_maps({_, Heap}) -> Heap#heap.maps. + +-spec heap_value_offset(heap_value()) -> offset(). +heap_value_offset({_, Heap}) -> Heap#heap.offset. + +-spec heap_value_heap(heap_value()) -> + binary() | #{non_neg_integer() => non_neg_integer()}. +heap_value_heap({_, Heap}) -> Heap#heap.heap. + +%% -- Value to binary -------------------------------------------------------- + +-spec to_binary(aeso_sophia:data()) -> aeso_sophia:heap(). +%% Encode the data as a heap where the first word is the value (for unboxed +%% types) or a pointer to the value (for boxed types). +to_binary(Data) -> + to_binary(Data, 0). + +to_binary(Data, BaseAddress) -> + {Address, Memory} = to_binary1(Data, BaseAddress + 32), + R = <>, + R. + + +%% Allocate the data in memory, from the given address. Return a pair +%% of memory contents from that address and the value representing the +%% data. +to_binary1(Data,_Address) when is_integer(Data) -> + {Data,<<>>}; +to_binary1(Data, Address) when is_binary(Data) -> + %% a string + Words = aeso_memory:binary_to_words(Data), + {Address,<<(size(Data)):256, << <> || W <- Words>>/binary>>}; +to_binary1(none, Address) -> to_binary1({variant, 0, []}, Address); +to_binary1({some, Value}, Address) -> to_binary1({variant, 1, [Value]}, Address); +to_binary1(word, Address) -> to_binary1({?TYPEREP_WORD_TAG}, Address); +to_binary1(string, Address) -> to_binary1({?TYPEREP_STRING_TAG}, Address); +to_binary1(typerep, Address) -> to_binary1({?TYPEREP_TYPEREP_TAG}, Address); +to_binary1(function, Address) -> to_binary1({?TYPEREP_FUN_TAG}, Address); +to_binary1({list, T}, Address) -> to_binary1({?TYPEREP_LIST_TAG, T}, Address); +to_binary1({option, T}, Address) -> to_binary1({variant, [[], [T]]}, Address); +to_binary1({tuple, Ts}, Address) -> to_binary1({?TYPEREP_TUPLE_TAG, Ts}, Address); +to_binary1({variant, Cons}, Address) -> to_binary1({?TYPEREP_VARIANT_TAG, Cons}, Address); +to_binary1({map, K, V}, Address) -> to_binary1({?TYPEREP_MAP_TAG, K, V}, Address); +to_binary1({variant, Tag, Args}, Address) -> + to_binary1(list_to_tuple([Tag | Args]), Address); +to_binary1(Map, Address) when is_map(Map) -> + Size = maps:size(Map), + %% Sort according to binary ordering + KVs = lists:sort([ {to_binary(K), to_binary(V)} || {K, V} <- maps:to_list(Map) ]), + {Address, <> || {K, V} <- KVs >>/binary >>}; +to_binary1({}, _Address) -> + {0, <<>>}; +to_binary1(Data, Address) when is_tuple(Data) -> + {Elems,Memory} = to_binaries(tuple_to_list(Data),Address+32*size(Data)), + ElemsBin = << <> || W <- Elems>>, + {Address,<< ElemsBin/binary, Memory/binary >>}; +to_binary1([],_Address) -> + <> = <<(-1):256>>, + {Nil,<<>>}; +to_binary1([H|T],Address) -> + to_binary1({H,T},Address). + + +to_binaries([],_Address) -> + {[],<<>>}; +to_binaries([H|T],Address) -> + {HRep,HMem} = to_binary1(H,Address), + {TRep,TMem} = to_binaries(T,Address+size(HMem)), + {[HRep|TRep],<>}. + +%% Interpret a return value (a binary) using a type rep. + +-spec from_heap(Type :: ?Type(), Heap :: binary(), Ptr :: integer()) -> + {ok, term()} | {error, term()}. +from_heap(Type, Heap, Ptr) -> + try {ok, from_binary(#{}, Type, Heap, Ptr)} + catch _:Err -> + %% io:format("** Error: from_heap failed with ~p\n ~p\n", [Err, erlang:get_stacktrace()]), + {error, Err} + end. + +%% Base address is the address of the first word of the given heap. +-spec from_binary(T :: ?Type(), + Heap :: binary(), + BaseAddr :: non_neg_integer()) -> + {ok, term()} | {error, term()}. +from_binary(T, Heap = <>, BaseAddr) -> + from_heap(T, <<0:BaseAddr/unit:8, Heap/binary>>, V); +from_binary(_, Bin, _BaseAddr) -> + {error, {binary_too_short, Bin}}. + +-spec from_binary(?Type(), binary()) -> {ok, term()} | {error, term()}. +from_binary(T, Heap) -> + from_binary(T, Heap, 0). + +from_binary(_, word, _, V) -> + V; +from_binary(_, signed_word, _, V) -> + <> = <>, + N; +from_binary(_, bool, _, V) -> + case V of + 0 -> false; + 1 -> true + end; +from_binary(_, string, Heap, V) -> + StringSize = heap_word(Heap,V), + BitAddr = 8*(V+32), + <<_:BitAddr,Bytes:StringSize/binary,_/binary>> = Heap, + Bytes; +from_binary(_, {tuple, []}, _, _) -> + {}; +from_binary(Visited, {tuple,Cpts}, Heap, V) -> + check_circular_refs(Visited, V), + NewVisited = Visited#{V => true}, + ElementNums = lists:seq(0, length(Cpts)-1), + TypesAndPointers = lists:zip(Cpts, ElementNums), + ElementAddress = fun(Index) -> V + 32 * Index end, + Element = fun(Index) -> + heap_word(Heap, ElementAddress(Index)) + end, + Convert = fun(Type, Index) -> + from_binary(NewVisited, Type, Heap, Element(Index)) + end, + Elements = [Convert(T, I) || {T,I} <- TypesAndPointers], + list_to_tuple(Elements); +from_binary(Visited, {list, Elem}, Heap, V) -> + <> = <<(-1):256>>, + if V==Nil -> + []; + true -> + {H,T} = from_binary(Visited, {tuple,[Elem,{list,Elem}]},Heap,V), + [H|T] + end; +from_binary(Visited, {option, A}, Heap, V) -> + from_binary(Visited, {variant_t, [{none, []}, {some, [A]}]}, Heap, V); +from_binary(Visited, {variant, Cons}, Heap, V) -> + Tag = heap_word(Heap, V), + Args = lists:nth(Tag + 1, Cons), + Visited1 = Visited#{V => true}, + {variant, Tag, tuple_to_list(from_binary(Visited1, {tuple, Args}, Heap, V + 32))}; +from_binary(Visited, {variant_t, TCons}, Heap, V) -> %% Tagged variants + {Tags, Cons} = lists:unzip(TCons), + {variant, I, Args} = from_binary(Visited, {variant, Cons}, Heap, V), + Tag = lists:nth(I + 1, Tags), + case Args of + [] -> Tag; + _ -> list_to_tuple([Tag | Args]) + end; +from_binary(_Visited, {map, A, B}, Heap, Ptr) -> + %% FORMAT: [Size] [KeySize] Key [ValSize] Val .. [KeySize] Key [ValSize] Val + Size = heap_word(Heap, Ptr), + map_binary_to_value(A, B, Size, Heap, Ptr + 32); +from_binary(Visited, typerep, Heap, V) -> + check_circular_refs(Visited, V), + Tag = heap_word(Heap, V), + Arg1 = fun(T, I) -> from_binary(Visited#{V => true}, T, Heap, heap_word(Heap, V + 32 * I)) end, + Arg = fun(T) -> Arg1(T, 1) end, + case Tag of + ?TYPEREP_WORD_TAG -> word; + ?TYPEREP_STRING_TAG -> string; + ?TYPEREP_TYPEREP_TAG -> typerep; + ?TYPEREP_LIST_TAG -> {list, Arg(typerep)}; + ?TYPEREP_TUPLE_TAG -> {tuple, Arg({list, typerep})}; + ?TYPEREP_VARIANT_TAG -> {variant, Arg({list, {list, typerep}})}; + ?TYPEREP_MAP_TAG -> {map, Arg(typerep), Arg1(typerep, 2)}; + ?TYPEREP_FUN_TAG -> function + end. + +map_binary_to_value(KeyType, ValType, N, Bin, Ptr) -> + %% Avoid looping on bogus sizes + MaxN = byte_size(Bin) div 64, + Heap = heap_fragment(Bin), + map_from_binary({value, KeyType, ValType}, min(N, MaxN), Heap, Ptr, #{}). + +map_from_binary(_, 0, _, _, Map) -> Map; +map_from_binary({value, KeyType, ValType} = Output, I, Heap, Ptr, Map) -> + KeySize = get_word(Heap, Ptr), + KeyPtr = Ptr + 32, + KeyBin = get_chunk(Heap, KeyPtr, KeySize), + ValSize = get_word(Heap, KeyPtr + KeySize), + ValPtr = KeyPtr + KeySize + 32, + ValBin = get_chunk(Heap, ValPtr, ValSize), + %% Keys and values are self contained binaries + {ok, Key} = from_binary(KeyType, KeyBin), + {ok, Val} = from_binary(ValType, ValBin), + map_from_binary(Output, I - 1, Heap, ValPtr + ValSize, Map#{Key => Val}). + +check_circular_refs(Visited, V) -> + case maps:is_key(V, Visited) of + true -> exit(circular_references); + false -> ok + end. + +heap_word(Heap, Addr) when is_binary(Heap) -> + BitSize = 8*Addr, + <<_:BitSize,W:256,_/binary>> = Heap, + W; +heap_word(Heap, Addr) when is_map(Heap) -> + 0 = Addr rem 32, %% Check that it's word aligned. + maps:get(Addr, Heap, 0). + +get_word(#heap{offset = Offs, heap = Mem}, Addr) when Addr >= Offs -> + get_word(Mem, Addr - Offs); +get_word(Mem, Addr) when is_binary(Mem) -> + <<_:Addr/unit:8, Word:256, _/binary>> = Mem, + Word. + +get_chunk(#heap{offset = Offs, heap = Mem}, Addr, Bytes) when Addr >= Offs -> + get_chunk(Mem, Addr - Offs, Bytes); +get_chunk(Mem, Addr, Bytes) when is_binary(Mem) -> + <<_:Addr/unit:8, Chunk:Bytes/binary, _/binary>> = Mem, + Chunk. + + + + diff --git a/src/aeso_heap.erl~ b/src/aeso_heap.erl~ new file mode 100644 index 0000000..25f3a8f --- /dev/null +++ b/src/aeso_heap.erl~ @@ -0,0 +1,301 @@ +-module(aeso_heap). + +-export([ to_binary/1 + , to_binary/2 + , from_heap/3 + , from_binary/2 + , from_binary/3 + , maps_with_next_id/1 + , set_next_id/2 + , heap_fragment/3 + , heap_value/3 + , heap_value/4 + , heap_value_pointer/1 + , heap_value_maps/1 + , heap_value_offset/1 + , heap_value_heap/1 + , heap_fragment_maps/1 + , heap_fragment_offset/1 + , heap_fragment_heap/1 + ]). + +-export_type([binary_value/0, heap_value/0, offset/0, heap_fragment/0]). + +-include("aeso_icode.hrl"). +-include_lib("sophia/include/aeso_heap.hrl"). + +-type word() :: non_neg_integer(). +-type pointer() :: word(). +-opaque heap_fragment() :: #heap{}. +-type offset() :: non_neg_integer(). +-type binary_value() :: binary(). +-type heap_value() :: {pointer(), heap_fragment()}. + + +-spec maps_with_next_id(heap_fragment()) -> #maps{}. +%% Create just a maps value, don't keep rest of Heap +maps_with_next_id(#heap{maps = #maps{next_id = N}}) -> + #maps{ next_id = N }. + +-spec set_next_id(heap_fragment(), non_neg_integer()) -> heap_fragment(). +set_next_id(Heap, N) -> + Heap#heap{ maps = Heap#heap.maps#maps{ next_id = N } }. + +%% -- data type heap_fragment + +-spec heap_fragment(binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment(). +heap_fragment(Heap) -> + heap_fragment(#maps{ next_id = 0 }, 0, Heap). + +-spec heap_fragment(#maps{}, offset(), + binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment(). +heap_fragment(Maps, Offset, Heap) -> + #heap{maps = Maps, offset = Offset, heap = Heap}. + +-spec heap_fragment_maps(heap_fragment()) -> #maps{}. +heap_fragment_maps(#heap{maps = Maps}) -> + Maps. + +-spec heap_fragment_offset(heap_fragment()) -> offset(). +heap_fragment_offset(#heap{offset = Offs}) -> + Offs. + +-spec heap_fragment_heap(heap_fragment()) -> binary() | #{non_neg_integer() => non_neg_integer()}. +heap_fragment_heap(#heap{heap = Heap}) -> + Heap. + + +%% -- data type heap_value + +-spec heap_value(#maps{}, pointer(), + binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_value(). +heap_value(Maps, Ptr, Heap) -> + heap_value(Maps, Ptr, Heap, 0). + +-spec heap_value(#maps{}, pointer(), + binary() | #{non_neg_integer() => non_neg_integer()}, offset()) -> heap_value(). +heap_value(Maps, Ptr, Heap, Offs) -> + {Ptr, heap_fragment(Maps, Offs, Heap)}. + +-spec heap_value_pointer(heap_value()) -> pointer(). +heap_value_pointer({Ptr, _}) -> Ptr. + +-spec heap_value_maps(heap_value()) -> #maps{}. +heap_value_maps({_, Heap}) -> Heap#heap.maps. + +-spec heap_value_offset(heap_value()) -> offset(). +heap_value_offset({_, Heap}) -> Heap#heap.offset. + +-spec heap_value_heap(heap_value()) -> + binary() | #{non_neg_integer() => non_neg_integer()}. +heap_value_heap({_, Heap}) -> Heap#heap.heap. + +%% -- Value to binary -------------------------------------------------------- + +-spec to_binary(aeso_sophia:data()) -> aeso_sophia:heap(). +%% Encode the data as a heap where the first word is the value (for unboxed +%% types) or a pointer to the value (for boxed types). +to_binary(Data) -> + to_binary(Data, 0). + +to_binary(Data, BaseAddress) -> + {Address, Memory} = to_binary1(Data, BaseAddress + 32), + R = <>, + R. + + +%% Allocate the data in memory, from the given address. Return a pair +%% of memory contents from that address and the value representing the +%% data. +to_binary1(Data,_Address) when is_integer(Data) -> + {Data,<<>>}; +to_binary1(Data, Address) when is_binary(Data) -> + %% a string + Words = aeso_memory:binary_to_words(Data), + {Address,<<(size(Data)):256, << <> || W <- Words>>/binary>>}; +to_binary1(none, Address) -> to_binary1({variant, 0, []}, Address); +to_binary1({some, Value}, Address) -> to_binary1({variant, 1, [Value]}, Address); +to_binary1(word, Address) -> to_binary1({?TYPEREP_WORD_TAG}, Address); +to_binary1(string, Address) -> to_binary1({?TYPEREP_STRING_TAG}, Address); +to_binary1(typerep, Address) -> to_binary1({?TYPEREP_TYPEREP_TAG}, Address); +to_binary1(function, Address) -> to_binary1({?TYPEREP_FUN_TAG}, Address); +to_binary1({list, T}, Address) -> to_binary1({?TYPEREP_LIST_TAG, T}, Address); +to_binary1({option, T}, Address) -> to_binary1({variant, [[], [T]]}, Address); +to_binary1({tuple, Ts}, Address) -> to_binary1({?TYPEREP_TUPLE_TAG, Ts}, Address); +to_binary1({variant, Cons}, Address) -> to_binary1({?TYPEREP_VARIANT_TAG, Cons}, Address); +to_binary1({map, K, V}, Address) -> to_binary1({?TYPEREP_MAP_TAG, K, V}, Address); +to_binary1({variant, Tag, Args}, Address) -> + to_binary1(list_to_tuple([Tag | Args]), Address); +to_binary1(Map, Address) when is_map(Map) -> + Size = maps:size(Map), + %% Sort according to binary ordering + KVs = lists:sort([ {to_binary(K), to_binary(V)} || {K, V} <- maps:to_list(Map) ]), + {Address, <> || {K, V} <- KVs >>/binary >>}; +to_binary1({}, _Address) -> + {0, <<>>}; +to_binary1(Data, Address) when is_tuple(Data) -> + {Elems,Memory} = to_binaries(tuple_to_list(Data),Address+32*size(Data)), + ElemsBin = << <> || W <- Elems>>, + {Address,<< ElemsBin/binary, Memory/binary >>}; +to_binary1([],_Address) -> + <> = <<(-1):256>>, + {Nil,<<>>}; +to_binary1([H|T],Address) -> + to_binary1({H,T},Address). + + +to_binaries([],_Address) -> + {[],<<>>}; +to_binaries([H|T],Address) -> + {HRep,HMem} = to_binary1(H,Address), + {TRep,TMem} = to_binaries(T,Address+size(HMem)), + {[HRep|TRep],<>}. + +%% Interpret a return value (a binary) using a type rep. + +-spec from_heap(Type :: ?Type(), Heap :: binary(), Ptr :: integer()) -> + {ok, term()} | {error, term()}. +from_heap(Type, Heap, Ptr) -> + try {ok, from_binary(#{}, Type, Heap, Ptr)} + catch _:Err -> + %% io:format("** Error: from_heap failed with ~p\n ~p\n", [Err, erlang:get_stacktrace()]), + {error, Err} + end. + +%% Base address is the address of the first word of the given heap. +-spec from_binary(T :: ?Type(), + Heap :: binary(), + BaseAddr :: non_neg_integer()) -> + {ok, term()} | {error, term()}. +from_binary(T, Heap = <>, BaseAddr) -> + from_heap(T, <<0:BaseAddr/unit:8, Heap/binary>>, V); +from_binary(_, Bin, _BaseAddr) -> + {error, {binary_too_short, Bin}}. + +-spec from_binary(?Type(), binary()) -> {ok, term()} | {error, term()}. +from_binary(T, Heap) -> + from_binary(T, Heap, 0). + +from_binary(_, word, _, V) -> + V; +from_binary(_, signed_word, _, V) -> + <> = <>, + N; +from_binary(_, bool, _, V) -> + case V of + 0 -> false; + 1 -> true + end; +from_binary(_, string, Heap, V) -> + StringSize = heap_word(Heap,V), + BitAddr = 8*(V+32), + <<_:BitAddr,Bytes:StringSize/binary,_/binary>> = Heap, + Bytes; +from_binary(_, {tuple, []}, _, _) -> + {}; +from_binary(Visited, {tuple,Cpts}, Heap, V) -> + check_circular_refs(Visited, V), + NewVisited = Visited#{V => true}, + ElementNums = lists:seq(0, length(Cpts)-1), + TypesAndPointers = lists:zip(Cpts, ElementNums), + ElementAddress = fun(Index) -> V + 32 * Index end, + Element = fun(Index) -> + heap_word(Heap, ElementAddress(Index)) + end, + Convert = fun(Type, Index) -> + from_binary(NewVisited, Type, Heap, Element(Index)) + end, + Elements = [Convert(T, I) || {T,I} <- TypesAndPointers], + list_to_tuple(Elements); +from_binary(Visited, {list, Elem}, Heap, V) -> + <> = <<(-1):256>>, + if V==Nil -> + []; + true -> + {H,T} = from_binary(Visited, {tuple,[Elem,{list,Elem}]},Heap,V), + [H|T] + end; +from_binary(Visited, {option, A}, Heap, V) -> + from_binary(Visited, {variant_t, [{none, []}, {some, [A]}]}, Heap, V); +from_binary(Visited, {variant, Cons}, Heap, V) -> + Tag = heap_word(Heap, V), + Args = lists:nth(Tag + 1, Cons), + Visited1 = Visited#{V => true}, + {variant, Tag, tuple_to_list(from_binary(Visited1, {tuple, Args}, Heap, V + 32))}; +from_binary(Visited, {variant_t, TCons}, Heap, V) -> %% Tagged variants + {Tags, Cons} = lists:unzip(TCons), + {variant, I, Args} = from_binary(Visited, {variant, Cons}, Heap, V), + Tag = lists:nth(I + 1, Tags), + case Args of + [] -> Tag; + _ -> list_to_tuple([Tag | Args]) + end; +from_binary(_Visited, {map, A, B}, Heap, Ptr) -> + %% FORMAT: [Size] [KeySize] Key [ValSize] Val .. [KeySize] Key [ValSize] Val + Size = heap_word(Heap, Ptr), + map_binary_to_value(A, B, Size, Heap, Ptr + 32); +from_binary(Visited, typerep, Heap, V) -> + check_circular_refs(Visited, V), + Tag = heap_word(Heap, V), + Arg1 = fun(T, I) -> from_binary(Visited#{V => true}, T, Heap, heap_word(Heap, V + 32 * I)) end, + Arg = fun(T) -> Arg1(T, 1) end, + case Tag of + ?TYPEREP_WORD_TAG -> word; + ?TYPEREP_STRING_TAG -> string; + ?TYPEREP_TYPEREP_TAG -> typerep; + ?TYPEREP_LIST_TAG -> {list, Arg(typerep)}; + ?TYPEREP_TUPLE_TAG -> {tuple, Arg({list, typerep})}; + ?TYPEREP_VARIANT_TAG -> {variant, Arg({list, {list, typerep}})}; + ?TYPEREP_MAP_TAG -> {map, Arg(typerep), Arg1(typerep, 2)}; + ?TYPEREP_FUN_TAG -> function + end. + +map_binary_to_value(KeyType, ValType, N, Bin, Ptr) -> + %% Avoid looping on bogus sizes + MaxN = byte_size(Bin) div 64, + Heap = heap_fragment(Bin), + map_from_binary({value, KeyType, ValType}, min(N, MaxN), Heap, Ptr, #{}). + +map_from_binary(_, 0, _, _, Map) -> Map; +map_from_binary({value, KeyType, ValType} = Output, I, Heap, Ptr, Map) -> + KeySize = get_word(Heap, Ptr), + KeyPtr = Ptr + 32, + KeyBin = get_chunk(Heap, KeyPtr, KeySize), + ValSize = get_word(Heap, KeyPtr + KeySize), + ValPtr = KeyPtr + KeySize + 32, + ValBin = get_chunk(Heap, ValPtr, ValSize), + %% Keys and values are self contained binaries + {ok, Key} = from_binary(KeyType, KeyBin), + {ok, Val} = from_binary(ValType, ValBin), + map_from_binary(Output, I - 1, Heap, ValPtr + ValSize, Map#{Key => Val}). + +check_circular_refs(Visited, V) -> + case maps:is_key(V, Visited) of + true -> exit(circular_references); + false -> ok + end. + +heap_word(Heap, Addr) when is_binary(Heap) -> + BitSize = 8*Addr, + <<_:BitSize,W:256,_/binary>> = Heap, + W; +heap_word(Heap, Addr) when is_map(Heap) -> + 0 = Addr rem 32, %% Check that it's word aligned. + maps:get(Addr, Heap, 0). + +get_word(#heap{offset = Offs, heap = Mem}, Addr) when Addr >= Offs -> + get_word(Mem, Addr - Offs); +get_word(Mem, Addr) when is_binary(Mem) -> + <<_:Addr/unit:8, Word:256, _/binary>> = Mem, + Word. + +get_chunk(#heap{offset = Offs, heap = Mem}, Addr, Bytes) when Addr >= Offs -> + get_chunk(Mem, Addr - Offs, Bytes); +get_chunk(Mem, Addr, Bytes) when is_binary(Mem) -> + <<_:Addr/unit:8, Chunk:Bytes/binary, _/binary>> = Mem, + Chunk. + + + + diff --git a/src/aeso_icode.erl b/src/aeso_icode.erl new file mode 100644 index 0000000..33fcc56 --- /dev/null +++ b/src/aeso_icode.erl @@ -0,0 +1,103 @@ +%%%------------------------------------------------------------------- +%%% @author Happi (Erik Stenman) +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc +%%% Intermediate Code for Aeterinty Sophia language. +%%% @end +%%% Created : 21 Dec 2017 +%%% +%%%------------------------------------------------------------------- +-module(aeso_icode). + +-export([new/1, pp/1, set_name/2, set_functions/2, map_typerep/2, option_typerep/1, get_constructor_tag/2]). +-export_type([icode/0]). + +-include("aeso_icode.hrl"). + +-type type_def() :: fun(([aeso_sophia:type()]) -> aeso_sophia:type()). + +-type bindings() :: any(). +-type fun_dec() :: { string() + , [modifier()] + , arg_list() + , expr() + , aeso_sophia:type()}. + +-type modifier() :: private | stateful. + +-type type_name() :: string() | [string()]. + +-type icode() :: #{ contract_name => string() + , functions => [fun_dec()] + , env => [bindings()] + , state_type => aeso_sophia:type() + , event_type => aeso_sophia:type() + , types => #{ type_name() => type_def() } + , type_vars => #{ string() => aeso_sophia:type() } + , constructors => #{ string() => integer() } %% name to tag + , options => [any()] + }. + +pp(Icode) -> + %% TODO: Actually do *Pretty* printing. + io:format("~p~n", [Icode]). + +-spec new([any()]) -> icode(). +new(Options) -> + #{ contract_name => "" + , functions => [] + , env => new_env() + %% Default to unit type for state and event + , state_type => {tuple, []} + , event_type => {tuple, []} + , types => builtin_types() + , type_vars => #{} + , constructors => builtin_constructors() + , options => Options}. + +builtin_types() -> + Word = fun([]) -> word end, + #{ "bool" => Word + , "int" => Word + , "string" => fun([]) -> string end + , "address" => Word + , "hash" => Word + , "signature" => fun([]) -> {tuple, [word, word]} end + , "oracle" => fun([_, _]) -> word end + , "oracle_query" => fun([_, _]) -> word end + , "list" => fun([A]) -> {list, A} end + , "option" => fun([A]) -> {variant, [[], [A]]} end + , "map" => fun([K, V]) -> map_typerep(K, V) end + , ["Chain", "ttl"] => fun([]) -> {variant, [[word], [word]]} end + }. + +builtin_constructors() -> + #{ "RelativeTTL" => 0 + , "FixedTTL" => 1 + , "None" => 0 + , "Some" => 1 }. + +map_typerep(K, V) -> + {map, K, V}. + +option_typerep(A) -> + {variant, [[], [A]]}. + +new_env() -> + []. + +-spec set_name(string(), icode()) -> icode(). +set_name(Name, Icode) -> + maps:put(contract_name, Name, Icode). + +-spec set_functions([fun_dec()], icode()) -> icode(). +set_functions(NewFuns, Icode) -> + maps:put(functions, NewFuns, Icode). + +-spec get_constructor_tag(string(), icode()) -> integer(). +get_constructor_tag(Name, #{constructors := Constructors}) -> + case maps:get(Name, Constructors, undefined) of + undefined -> error({undefined_constructor, Name}); + Tag -> Tag + end. + diff --git a/src/aeso_icode.hrl b/src/aeso_icode.hrl new file mode 100644 index 0000000..2fdabf5 --- /dev/null +++ b/src/aeso_icode.hrl @@ -0,0 +1,68 @@ + +-define(Type(), aeso_sophia:type()). + +-define(TYPEREP_WORD_TAG, 0). +-define(TYPEREP_STRING_TAG, 1). +-define(TYPEREP_LIST_TAG, 2). +-define(TYPEREP_TUPLE_TAG, 3). +-define(TYPEREP_VARIANT_TAG, 4). +-define(TYPEREP_TYPEREP_TAG, 5). +-define(TYPEREP_MAP_TAG, 6). +-define(TYPEREP_FUN_TAG, 7). + +-record(arg, {name::string(), type::?Type()}). + +-type expr() :: term(). +-type arg() :: #arg{name::string(), type::?Type()}. +-type arg_list() :: [arg()]. + +-record(fun_dec, { name :: string() + , args :: arg_list() + , body :: expr()}). + +-record(var_ref, { name :: string() | {builtin, atom() | tuple()}}). + +-record(prim_call_contract, + { gas :: expr() + , address :: expr() + , value :: expr() + , arg :: expr() + , type_hash:: expr() + }). + +-record(prim_balance, { address :: expr() }). +-record(prim_block_hash, { height :: expr() }). +-record(prim_put, { state :: expr() }). + +-record(integer, {value :: integer()}). + +-record(tuple, {cpts :: [expr()]}). + +-record(list, {elems :: [expr()]}). + +-record(unop, { op :: term() + , rand :: expr()}). + +-record(binop, { op :: term() + , left :: expr() + , right :: expr()}). + +-record(ifte, { decision :: expr() + , then :: expr() + , else :: expr()}). + +-record(switch, { expr :: expr() + , cases :: [{expr(),expr()}]}). + +-record(funcall, { function :: expr() + , args :: [expr()]}). + +-record(lambda, { args :: arg_list(), + body :: expr()}). + +-record(missing_field, { format :: string() + , args :: [term()]}). + +-record(seq, {exprs :: [expr()]}). + +-record(event, {topics :: [expr()], payload :: expr()}). diff --git a/src/aeso_icode_to_asm.erl b/src/aeso_icode_to_asm.erl new file mode 100644 index 0000000..b9cd3e3 --- /dev/null +++ b/src/aeso_icode_to_asm.erl @@ -0,0 +1,979 @@ +%%%------------------------------------------------------------------- +%%% @author Happi (Erik Stenman) +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc +%%% Translator from Aesophia Icode to Aevm Assebly +%%% @end +%%% Created : 21 Dec 2017 +%%% +%%%------------------------------------------------------------------- +-module(aeso_icode_to_asm). + +-export([convert/2]). + +-include_lib("aebytecode/include/aeb_opcodes.hrl"). +-include("aeso_icode.hrl"). + +i(Code) -> aeb_opcodes:mnemonic(Code). + +%% We don't track purity or statefulness in the type checker yet. +is_stateful({FName, _, _, _, _}) -> FName /= "init". + +is_public({_Name, Attrs, _Args, _Body, _Type}) -> not lists:member(private, Attrs). + +convert(#{ contract_name := _ContractName + , state_type := StateType + , functions := Functions + }, + _Options) -> + %% Create a function dispatcher + DispatchFun = {"_main", [], [{"arg", "_"}], + {switch, {var_ref, "arg"}, + [{{tuple, [fun_hash(Fun), + {tuple, make_args(Args)}]}, + icode_seq([ hack_return_address(Fun, length(Args) + 1) ] ++ + [ {funcall, {var_ref, FName}, make_args(Args)}] + )} + || Fun={FName, _, Args, _,_TypeRep} <- Functions, is_public(Fun) ]}, + word}, + NewFunctions = Functions ++ [DispatchFun], + %% Create a function environment + Funs = [{Name, length(Args), make_ref()} + || {Name, _Attrs, Args, _Body, _Type} <- NewFunctions], + %% Create dummy code to call the main function with one argument + %% taken from the stack + StopLabel = make_ref(), + StatefulStopLabel = make_ref(), + MainFunction = lookup_fun(Funs, "_main"), + + StateTypeValue = aeso_ast_to_icode:type_value(StateType), + + DispatchCode = [%% push two return addresses to stop, one for stateful + %% functions and one for non-stateful functions. + push_label(StatefulStopLabel), + push_label(StopLabel), + %% The calldata is already on the stack when we start. Put + %% it on top (also reorders StatefulStop and Stop). + swap(2), + + jump(MainFunction), + jumpdest(StatefulStopLabel), + + %% We need to encode the state type and put it + %% underneath the return value. + assemble_expr(Funs, [], nontail, StateTypeValue), %% StateT Ret + swap(1), %% Ret StateT + + %% We should also change the state value at address 0 to a + %% pointer to the state value (to allow 0 to represent an + %% unchanged state). + i(?MSIZE), %% Ptr + push(0), i(?MLOAD), %% Val Ptr + i(?MSIZE), i(?MSTORE), %% Ptr Mem[Ptr] := Val + push(0), i(?MSTORE), %% Mem[0] := Ptr + + %% The pointer to the return value is on top of + %% the stack, but the return instruction takes two + %% stack arguments. + push(0), + i(?RETURN), + jumpdest(StopLabel), + %% Set state pointer to 0 to indicate that we didn't change state + push(0), dup(1), i(?MSTORE), + %% Same as StatefulStopLabel above + push(0), + i(?RETURN) + ], + %% Code is a deep list of instructions, containing labels and + %% references to them. Labels take the form {'JUMPDEST', Ref}, and + %% references take the form {push_label, Ref}, which is translated + %% into a PUSH instruction. + Code = [assemble_function(Funs, Name, Args, Body) + || {Name, _, Args, Body, _Type} <- NewFunctions], + resolve_references( + [%% i(?COMMENT), "CONTRACT: " ++ ContractName, + DispatchCode, + Code]). + +%% Generate error on correct format. + +gen_error(Error) -> + error({code_errors, [Error]}). + +make_args(Args) -> + [{var_ref, [I-1 + $a]} || I <- lists:seq(1, length(Args))]. + +fun_hash({FName, _, Args, _, TypeRep}) -> + ArgType = {tuple, [T || {_, T} <- Args]}, + <> = aeso_abi:function_type_hash(list_to_binary(FName), ArgType, TypeRep), + {integer, Hash}. + +%% Expects two return addresses below N elements on the stack. Picks the top +%% one for stateful functions and the bottom one for non-stateful. +hack_return_address(Fun, N) -> + case is_stateful(Fun) of + true -> {inline_asm, [i(?MSIZE)]}; + false -> + {inline_asm, %% X1 .. XN State NoState + [ dup(N + 2) %% NoState X1 .. XN State NoState + , swap(N + 1) %% State X1 .. XN NoState NoState + ]} %% Top of the stack will be discarded. + end. + +assemble_function(Funs, Name, Args, Body) -> + [jumpdest(lookup_fun(Funs, Name)), + assemble_expr(Funs, lists:reverse(Args), tail, Body), + %% swap return value and first argument + pop_args(length(Args)), + swap(1), + i(?JUMP)]. + +%% {seq, Es} - should be "one" operation in terms of stack content +%% i.e. after the `seq` there should be one new element on the stack. +assemble_expr(Funs, Stack, Tail, {seq, [E]}) -> + assemble_expr(Funs, Stack, Tail, E); +assemble_expr(Funs, Stack, Tail, {seq, [E | Es]}) -> + [assemble_expr(Funs, Stack, nontail, E), + assemble_expr(Funs, Stack, Tail, {seq, Es})]; +assemble_expr(_Funs, _Stack, _Tail, {inline_asm, Code}) -> + Code; %% Unsafe! Code should take care to respect the stack! +assemble_expr(Funs, Stack, _TailPosition, {var_ref, Id}) -> + case lists:keymember(Id, 1, Stack) of + true -> + dup(lookup_var(Id, Stack)); + false -> + %% Build a closure + %% When a top-level fun is called directly, we do not + %% reach this case. + Eta = make_ref(), + Continue = make_ref(), + [i(?MSIZE), + push_label(Eta), + dup(2), + i(?MSTORE), + jump(Continue), + %% the code of the closure + jumpdest(Eta), + %% pop the pointer to the function + pop(1), + jump(lookup_fun(Funs, Id)), + jumpdest(Continue)] + end; +assemble_expr(_, _, _, {missing_field, Format, Args}) -> + io:format(Format, Args), + gen_error(missing_field); +assemble_expr(_Funs, _Stack, _, {integer, N}) -> + push(N); +assemble_expr(Funs, Stack, _, {tuple, Cpts}) -> + %% We build tuples right-to-left, so that the first write to the + %% tuple extends the memory size. Because we use ?MSIZE as the + %% heap pointer, we must allocate the tuple AFTER computing the + %% first element. + %% We store elements into the tuple as soon as possible, to avoid + %% keeping them for a long time on the stack. + case lists:reverse(Cpts) of + [] -> + i(?MSIZE); + [Last|Rest] -> + [assemble_expr(Funs, Stack, nontail, Last), + %% allocate the tuple memory + i(?MSIZE), + %% compute address of last word + push(32 * (length(Cpts) - 1)), i(?ADD), + %% Stack: + %% Write value to memory (allocates the tuple) + swap(1), dup(2), i(?MSTORE), + %% Stack: pointer to last word written + [[%% Update pointer to next word to be written + push(32), swap(1), i(?SUB), + %% Compute element + assemble_expr(Funs, [pointer|Stack], nontail, A), + %% Write element to memory + dup(2), i(?MSTORE)] + %% And we leave a pointer to the last word written on + %% the stack + || A <- Rest]] + %% The pointer to the entire tuple is on the stack + end; +assemble_expr(_Funs, _Stack, _, {list, []}) -> + %% Use Erik's value of -1 for [] + [push(0), i(?NOT)]; +assemble_expr(Funs, Stack, _, {list, [A|B]}) -> + assemble_expr(Funs, Stack, nontail, {tuple, [A, {list, B}]}); +assemble_expr(Funs, Stack, _, {unop, '!', A}) -> + case A of + {binop, Logical, _, _} when Logical=='&&'; Logical=='||' -> + assemble_expr(Funs, Stack, nontail, {ifte, A, {integer, 0}, {integer, 1}}); + _ -> + [assemble_expr(Funs, Stack, nontail, A), + i(?ISZERO) + ] + end; +assemble_expr(Funs, Stack, _, {event, Topics, Payload}) -> + [assemble_exprs(Funs, Stack, Topics ++ [Payload]), + case length(Topics) of + 0 -> i(?LOG0); + 1 -> i(?LOG1); + 2 -> i(?LOG2); + 3 -> i(?LOG3); + 4 -> i(?LOG4) + end, i(?MSIZE)]; +assemble_expr(Funs, Stack, _, {unop, Op, A}) -> + [assemble_expr(Funs, Stack, nontail, A), + assemble_prefix(Op)]; +assemble_expr(Funs, Stack, Tail, {binop, '&&', A, B}) -> + assemble_expr(Funs, Stack, Tail, {ifte, A, B, {integer, 0}}); +assemble_expr(Funs, Stack, Tail, {binop, '||', A, B}) -> + assemble_expr(Funs, Stack, Tail, {ifte, A, {integer, 1}, B}); +assemble_expr(Funs, Stack, Tail, {binop, '::', A, B}) -> + %% Take advantage of optimizations in tuple construction. + assemble_expr(Funs, Stack, Tail, {tuple, [A, B]}); +assemble_expr(Funs, Stack, _, {binop, Op, A, B}) -> + %% EEVM binary instructions take their first argument from the top + %% of the stack, so to get operands on the stack in the right + %% order, we evaluate from right to left. + [assemble_expr(Funs, Stack, nontail, B), + assemble_expr(Funs, [dummy|Stack], nontail, A), + assemble_infix(Op)]; +assemble_expr(Funs, Stack, _, {lambda, Args, Body}) -> + Function = make_ref(), + FunBody = make_ref(), + Continue = make_ref(), + NoMatch = make_ref(), + FreeVars = free_vars({lambda, Args, Body}), + {NewVars, MatchingCode} = assemble_pattern(FunBody, NoMatch, {tuple, [{var_ref, "_"}|FreeVars]}), + BodyCode = assemble_expr(Funs, NewVars ++ lists:reverse([ {Arg#arg.name, Arg#arg.type} || Arg <- Args ]), tail, Body), + [assemble_expr(Funs, Stack, nontail, {tuple, [{label, Function}|FreeVars]}), + jump(Continue), %% will be optimized away + jumpdest(Function), + %% A pointer to the closure is on the stack + MatchingCode, + jumpdest(FunBody), + BodyCode, + pop_args(length(Args)+length(NewVars)), + swap(1), + i(?JUMP), + jumpdest(NoMatch), %% dead code--raise an exception just in case + push(0), + i(?NOT), + i(?MLOAD), + i(?STOP), + jumpdest(Continue)]; +assemble_expr(_, _, _, {label, Label}) -> + push_label(Label); +assemble_expr(Funs, Stack, nontail, {funcall, Fun, Args}) -> + Return = make_ref(), + %% This is the obvious code: + %% [{push_label, Return}, + %% assemble_exprs(Funs, [return_address|Stack], Args++[Fun]), + %% 'JUMP', + %% {'JUMPDEST', Return}]; + %% Its problem is that it stores the return address on the stack + %% while the arguments are computed, which is unnecessary. To + %% avoid that, we compute the last argument FIRST, and replace it + %% with the return address using a SWAP. + %% + %% assemble_function leaves the code pointer of the function to + %% call on top of the stack, and--if the function is not a + %% top-level name--a pointer to its tuple of free variables. In + %% either case a JUMP is the right way to call it. + case Args of + [] -> + [push_label(Return), + assemble_function(Funs, [return_address|Stack], Fun), + i(?JUMP), + jumpdest(Return)]; + _ -> + {Init, [Last]} = lists:split(length(Args) - 1, Args), + [assemble_exprs(Funs, Stack, [Last|Init]), + %% Put the return address in the right place, which also + %% reorders the args correctly. + push_label(Return), + swap(length(Args)), + assemble_function(Funs, [dummy || _ <- Args] ++ [return_address|Stack], Fun), + i(?JUMP), + jumpdest(Return)] + end; +assemble_expr(Funs, Stack, tail, {funcall, Fun, Args}) -> + IsTopLevel = is_top_level_fun(Stack, Fun), + %% If the fun is not top-level, then it may refer to local + %% variables and must be computed before stack shuffling. + ArgsAndFun = Args++[Fun || not IsTopLevel], + ComputeArgsAndFun = assemble_exprs(Funs, Stack, ArgsAndFun), + %% Copy arguments back down the stack to the start of the frame + ShuffleSpec = lists:seq(length(ArgsAndFun), 1, -1) ++ [discard || _ <- Stack], + Shuffle = shuffle_stack(ShuffleSpec), + [ComputeArgsAndFun, Shuffle, + if IsTopLevel -> + %% still need to compute function + assemble_function(Funs, [], Fun); + true -> + %% need to unpack a closure + [dup(1), i(?MLOAD)] + end, + i(?JUMP)]; +assemble_expr(Funs, Stack, Tail, {ifte, Decision, Then, Else}) -> + %% This compilation scheme introduces a lot of labels and + %% jumps. Unnecessary ones are removed later in + %% resolve_references. + Close = make_ref(), + ThenL = make_ref(), + ElseL = make_ref(), + [assemble_decision(Funs, Stack, Decision, ThenL, ElseL), + jumpdest(ElseL), + assemble_expr(Funs, Stack, Tail, Else), + jump(Close), + jumpdest(ThenL), + assemble_expr(Funs, Stack, Tail, Then), + jumpdest(Close) + ]; +assemble_expr(Funs, Stack, Tail, {switch, A, Cases}) -> + Close = make_ref(), + [assemble_expr(Funs, Stack, nontail, A), + assemble_cases(Funs, Stack, Tail, Close, Cases), + {'JUMPDEST', Close}]; +%% State primitives +%% (A pointer to) the contract state is stored at address 0. +assemble_expr(_Funs, _Stack, _Tail, prim_state) -> + [push(0), i(?MLOAD)]; +assemble_expr(Funs, Stack, _Tail, #prim_put{ state = State }) -> + [assemble_expr(Funs, Stack, nontail, State), + push(0), i(?MSTORE), %% We need something for the unit value on the stack, + i(?MSIZE)]; %% MSIZE is the cheapest instruction. +%% Environment primitives +assemble_expr(_Funs, _Stack, _Tail, prim_contract_address) -> + [i(?ADDRESS)]; +assemble_expr(_Funs, _Stack, _Tail, prim_call_origin) -> + [i(?ORIGIN)]; +assemble_expr(_Funs, _Stack, _Tail, prim_caller) -> + [i(?CALLER)]; +assemble_expr(_Funs, _Stack, _Tail, prim_call_value) -> + [i(?CALLVALUE)]; +assemble_expr(_Funs, _Stack, _Tail, prim_gas_price) -> + [i(?GASPRICE)]; +assemble_expr(_Funs, _Stack, _Tail, prim_gas_left) -> + [i(?GAS)]; +assemble_expr(_Funs, _Stack, _Tail, prim_coinbase) -> + [i(?COINBASE)]; +assemble_expr(_Funs, _Stack, _Tail, prim_timestamp) -> + [i(?TIMESTAMP)]; +assemble_expr(_Funs, _Stack, _Tail, prim_block_height) -> + [i(?NUMBER)]; +assemble_expr(_Funs, _Stack, _Tail, prim_difficulty) -> + [i(?DIFFICULTY)]; +assemble_expr(_Funs, _Stack, _Tail, prim_gas_limit) -> + [i(?GASLIMIT)]; +assemble_expr(Funs, Stack, _Tail, #prim_balance{ address = Addr }) -> + [assemble_expr(Funs, Stack, nontail, Addr), + i(?BALANCE)]; +assemble_expr(Funs, Stack, _Tail, #prim_block_hash{ height = Height }) -> + [assemble_expr(Funs, Stack, nontail, Height), + i(?BLOCKHASH)]; +assemble_expr(Funs, Stack, _Tail, + #prim_call_contract{ gas = Gas + , address = To + , value = Value + , arg = Arg + , type_hash= TypeHash + }) -> + %% ?CALL takes (from the top) + %% Gas, To, Value, Arg, TypeHash, _OOffset,_OSize + %% So assemble these in reverse order. + [ assemble_exprs(Funs, Stack, [ {integer, 0}, {integer, 0}, TypeHash + , Arg, Value, To, Gas ]) + , i(?CALL) + ]. + + +assemble_exprs(_Funs, _Stack, []) -> + []; +assemble_exprs(Funs, Stack, [E|Es]) -> + [assemble_expr(Funs, Stack, nontail, E), + assemble_exprs(Funs, [dummy|Stack], Es)]. + +assemble_decision(Funs, Stack, {binop, '&&', A, B}, Then, Else) -> + Label = make_ref(), + [assemble_decision(Funs, Stack, A, Label, Else), + jumpdest(Label), + assemble_decision(Funs, Stack, B, Then, Else)]; +assemble_decision(Funs, Stack, {binop, '||', A, B}, Then, Else) -> + Label = make_ref(), + [assemble_decision(Funs, Stack, A, Then, Label), + jumpdest(Label), + assemble_decision(Funs, Stack, B, Then, Else)]; +assemble_decision(Funs, Stack, {unop, '!', A}, Then, Else) -> + assemble_decision(Funs, Stack, A, Else, Then); +assemble_decision(Funs, Stack, {ifte, A, B, C}, Then, Else) -> + TrueL = make_ref(), + FalseL = make_ref(), + [assemble_decision(Funs, Stack, A, TrueL, FalseL), + jumpdest(TrueL), assemble_decision(Funs, Stack, B, Then, Else), + jumpdest(FalseL), assemble_decision(Funs, Stack, C, Then, Else)]; +assemble_decision(Funs, Stack, Decision, Then, Else) -> + [assemble_expr(Funs, Stack, nontail, Decision), + jump_if(Then), jump(Else)]. + +%% Entered with value to switch on on top of the stack +%% Evaluate selected case, then jump to Close with result on the +%% stack. +assemble_cases(_Funs, _Stack, _Tail, _Close, []) -> + %% No match! What should be do? There's no real way to raise an + %% exception, except consuming all the gas. + %% There should not be enough gas to do this: + [push(1), i(?NOT), + i(?MLOAD), + %% now stop, so that jump optimizer realizes we will not fall + %% through this code. + i(?STOP)]; +assemble_cases(Funs, Stack, Tail, Close, [{Pattern, Body}|Cases]) -> + Succeed = make_ref(), + Fail = make_ref(), + {NewVars, MatchingCode} = + assemble_pattern(Succeed, Fail, Pattern), + %% In the code that follows, if this is NOT the last case, then we + %% save the value being switched on, and discard it on + %% success. The code is simpler if this IS the last case. + [[dup(1) || Cases /= []], %% save value for next case, if there is one + MatchingCode, + jumpdest(Succeed), + %% Discard saved value, if we saved one + [case NewVars of + [] -> + pop(1); + [_] -> + %% Special case for peep-hole optimization + pop_args(1); + _ -> + [swap(length(NewVars)), pop(1)] + end + || Cases/=[]], + assemble_expr(Funs, + case Cases of + [] -> NewVars; + _ -> reorder_vars(NewVars) + end + ++Stack, Tail, Body), + %% If the Body makes a tail call, then we will not return + %% here--but it doesn't matter, because + %% (a) the NewVars will be popped before the tailcall + %% (b) the code below will be deleted since it is dead + pop_args(length(NewVars)), + jump(Close), + jumpdest(Fail), + assemble_cases(Funs, Stack, Tail, Close, Cases)]. + +%% Entered with value to match on top of the stack. +%% Generated code removes value, and +%% - jumps to Fail if no match, or +%% - binds variables, leaves them on the stack, and jumps to Succeed +%% Result is a list of variables to add to the stack, and the matching +%% code. +assemble_pattern(Succeed, Fail, {integer, N}) -> + {[], [push(N), + i(?EQ), + jump_if(Succeed), + jump(Fail)]}; +assemble_pattern(Succeed, _Fail, {var_ref, "_"}) -> + {[], [i(?POP), jump(Succeed)]}; +assemble_pattern(Succeed, Fail, {missing_field, _, _}) -> + %% Missing record fields are quite ok in patterns. + assemble_pattern(Succeed, Fail, {var_ref, "_"}); +assemble_pattern(Succeed, _Fail, {var_ref, Id}) -> + {[{Id, "_"}], jump(Succeed)}; +assemble_pattern(Succeed, _Fail, {tuple, []}) -> + {[], [pop(1), jump(Succeed)]}; +assemble_pattern(Succeed, Fail, {tuple, [A]}) -> + %% Treat this case specially, because we don't need to save the + %% pointer to the tuple. + {AVars, ACode} = assemble_pattern(Succeed, Fail, A), + {AVars, [i(?MLOAD), + ACode]}; +assemble_pattern(Succeed, Fail, {tuple, [A|B]}) -> + %% Entered with the address of the tuple on the top of the + %% stack. We will duplicate the address before matching on A. + Continue = make_ref(), %% the label for matching B + Pop1Fail = make_ref(), %% pop 1 word and goto Fail + PopNFail = make_ref(), %% pop length(AVars) words and goto Fail + {AVars, ACode} = + assemble_pattern(Continue, Pop1Fail, A), + {BVars, BCode} = + assemble_pattern(Succeed, PopNFail, {tuple, B}), + {BVars ++ reorder_vars(AVars), + [%% duplicate the pointer so we don't lose it when we match on A + dup(1), + i(?MLOAD), + ACode, + jumpdest(Continue), + %% Bring the pointer to the top of the stack--this reorders AVars! + swap(length(AVars)), + push(32), + i(?ADD), + BCode, + case AVars of + [] -> + [jumpdest(Pop1Fail), pop(1), + jumpdest(PopNFail), + jump(Fail)]; + _ -> + [{'JUMPDEST', PopNFail}, pop(length(AVars)-1), + {'JUMPDEST', Pop1Fail}, pop(1), + {push_label, Fail}, 'JUMP'] + end]}; +assemble_pattern(Succeed, Fail, {list, []}) -> + %% [] is represented by -1. + {[], [push(1), + i(?ADD), + jump_if(Fail), + jump(Succeed)]}; +assemble_pattern(Succeed, Fail, {list, [A|B]}) -> + assemble_pattern(Succeed, Fail, {binop, '::', A, {list, B}}); +assemble_pattern(Succeed, Fail, {binop, '::', A, B}) -> + %% Make sure it's not [], then match as tuple. + NotNil = make_ref(), + {Vars, Code} = assemble_pattern(Succeed, Fail, {tuple, [A, B]}), + {Vars, [dup(1), push(1), i(?ADD), %% Check for [] without consuming the value + jump_if(NotNil), %% so it's still there when matching the tuple. + pop(1), %% It was [] so discard the saved value. + jump(Fail), + jumpdest(NotNil), + Code]}. + +%% When Vars are on the stack, with a value we want to discard +%% below them, then we swap the top variable with that value and pop. +%% This reorders the variables on the stack, as follows: +reorder_vars([]) -> + []; +reorder_vars([V|Vs]) -> + Vs ++ [V]. + +assemble_prefix('sha3') -> [i(?DUP1), i(?MLOAD), %% length, ptr + i(?SWAP1), push(32), i(?ADD), %% ptr+32, length + i(?SHA3)]; +assemble_prefix('-') -> [push(0), i(?SUB)]; +assemble_prefix('bnot') -> i(?NOT). + +assemble_infix('+') -> i(?ADD); +assemble_infix('-') -> i(?SUB); +assemble_infix('*') -> i(?MUL); +assemble_infix('/') -> i(?SDIV); +assemble_infix('div') -> i(?DIV); +assemble_infix('mod') -> i(?MOD); +assemble_infix('^') -> i(?EXP); +assemble_infix('bor') -> i(?OR); +assemble_infix('band') -> i(?AND); +assemble_infix('bxor') -> i(?XOR); +assemble_infix('<') -> i(?SLT); %% comparisons are SIGNED +assemble_infix('>') -> i(?SGT); +assemble_infix('==') -> i(?EQ); +assemble_infix('<=') -> [i(?SGT), i(?ISZERO)]; +assemble_infix('=<') -> [i(?SGT), i(?ISZERO)]; +assemble_infix('>=') -> [i(?SLT), i(?ISZERO)]; +assemble_infix('!=') -> [i(?EQ), i(?ISZERO)]; +assemble_infix('!') -> [i(?ADD), i(?MLOAD)]; +assemble_infix('byte') -> i(?BYTE). +%% assemble_infix('::') -> [i(?MSIZE), write_word(0), write_word(1)]. + +%% a function may either refer to a top-level function, in which case +%% we fetch the code label from Funs, or it may be a lambda-expression +%% (including a top-level function passed as a parameter). In the +%% latter case, the function value is a pointer to a tuple of the code +%% pointer and the free variables: we keep the pointer and push the +%% code pointer onto the stack. In either case, we are ready to enter +%% the function with JUMP. +assemble_function(Funs, Stack, Fun) -> + case is_top_level_fun(Stack, Fun) of + true -> + {var_ref, Name} = Fun, + {push_label, lookup_fun(Funs, Name)}; + false -> + [assemble_expr(Funs, Stack, nontail, Fun), + dup(1), + i(?MLOAD)] + end. + +free_vars(V={var_ref, _}) -> + [V]; +free_vars({switch, E, Cases}) -> + lists:umerge(free_vars(E), + lists:umerge([free_vars(Body)--free_vars(Pattern) + || {Pattern, Body} <- Cases])); +free_vars({lambda, Args, Body}) -> + free_vars(Body) -- [{var_ref, Arg#arg.name} || Arg <- Args]; +free_vars(T) when is_tuple(T) -> + free_vars(tuple_to_list(T)); +free_vars([H|T]) -> + lists:umerge(free_vars(H), free_vars(T)); +free_vars(_) -> + []. + + + +%% shuffle_stack reorders the stack, for example before a tailcall. It is called +%% with a description of the current stack, and how the final stack +%% should appear. The argument is a list containing +%% a NUMBER for each element that should be kept, the number being +%% the position this element should occupy in the final stack +%% discard, for elements that can be discarded. +%% The positions start at 1, referring to the variable to be placed at +%% the bottom of the stack, and ranging up to the size of the final stack. +shuffle_stack([]) -> + []; +shuffle_stack([discard|Stack]) -> + [i(?POP) | shuffle_stack(Stack)]; +shuffle_stack([N|Stack]) -> + case length(Stack) + 1 - N of + 0 -> + %% the job should be finished + CorrectStack = lists:seq(N - 1, 1, -1), + CorrectStack = Stack, + []; + MoveBy -> + {Pref, [_|Suff]} = lists:split(MoveBy - 1, Stack), + [swap(MoveBy) | shuffle_stack([lists:nth(MoveBy, Stack) | Pref ++ [N|Suff]])] + end. + + + +lookup_fun(Funs, Name) -> + case [Ref || {Name1, _, Ref} <- Funs, + Name == Name1] of + [Ref] -> Ref; + [] -> gen_error({undefined_function, Name}) + end. + +is_top_level_fun(Stack, {var_ref, Id}) -> + not lists:keymember(Id, 1, Stack); +is_top_level_fun(_, _) -> + false. + +lookup_var(Id, Stack) -> + lookup_var(1, Id, Stack). + +lookup_var(N, Id, [{Id, _Type}|_]) -> + N; +lookup_var(N, Id, [_|Stack]) -> + lookup_var(N + 1, Id, Stack); +lookup_var(_, Id, []) -> + gen_error({var_not_in_scope, Id}). + +%% Smart instruction generation + +%% TODO: handle references to the stack beyond depth 16. Perhaps the +%% best way is to repush variables that will be needed in +%% subexpressions before evaluating he subexpression... i.e. fix the +%% problem in assemble_expr, rather than here. A fix here would have +%% to save the top elements of the stack in memory, duplicate the +%% targetted element, and then repush the values from memory. +dup(N) when 1 =< N, N =< 16 -> + i(?DUP1 + N - 1). + +push(N) -> + Bytes = binary:encode_unsigned(N), + true = size(Bytes) =< 32, + [i(?PUSH1 + size(Bytes) - 1) | + binary_to_list(Bytes)]. + +%% Pop N values from UNDER the top element of the stack. +%% This is a pseudo-instruction so peephole optimization can +%% combine pop_args(M), pop_args(N) to pop_args(M+N) +pop_args(0) -> + []; +pop_args(N) -> + {pop_args, N}. +%% [swap(N), pop(N)]. + +pop(N) -> + [i(?POP) || _ <- lists:seq(1, N)]. + +swap(0) -> + %% Doesn't exist, but is logically a no-op. + []; +swap(N) when 1 =< N, N =< 16 -> + i(?SWAP1 + N - 1). + +jumpdest(Label) -> {i(?JUMPDEST), Label}. +push_label(Label) -> {push_label, Label}. + +jump(Label) -> [push_label(Label), i(?JUMP)]. +jump_if(Label) -> [push_label(Label), i(?JUMPI)]. + +%% ICode utilities (TODO: move to separate module) + +icode_noname() -> #var_ref{name = "_"}. + +icode_seq([A]) -> A; +icode_seq([A | As]) -> + icode_seq(A, icode_seq(As)). + +icode_seq(A, B) -> + #switch{ expr = A, cases = [{icode_noname(), B}] }. + +%% Stack: ADDR +%% Write elements at addresses ADDR, ADDR+32, ADDR+64... +%% Stack afterwards: ADDR +% write_words(N) -> +% [write_word(I) || I <- lists:seq(N-1, 0, -1)]. + +%% Unused at the moment. Comment out to please dialyzer. +%% write_word(I) -> +%% [%% Stack: elements e ADDR +%% swap(1), +%% dup(2), +%% %% Stack: elements ADDR e ADDR +%% push(32*I), +%% i(?ADD), +%% %% Stack: elements ADDR e ADDR+32I +%% i(?MSTORE)]. + +%% Resolve references, and convert code from deep list to flat list. +%% List elements are: +%% Opcodes +%% Byte values +%% {'JUMPDEST', Ref} -- assembles to ?JUMPDEST and sets Ref +%% {push_label, Ref} -- assembles to ?PUSHN address bytes + +%% For now, we assemble all code addresses as three bytes. + +resolve_references(Code) -> + Peephole = peep_hole(lists:flatten(Code)), + %% WARNING: Optimizing jumps reorders the code and deletes + %% instructions. When debugging the assemble_ functions, it can be + %% useful to replace the next line by: + %% Instrs = lists:flatten(Code), + %% thus disabling the optimization. + OptimizedJumps = optimize_jumps(Peephole), + Instrs = lists:reverse(peep_hole_backwards(lists:reverse(OptimizedJumps))), + Labels = define_labels(0, Instrs), + lists:flatten([use_labels(Labels, I) || I <- Instrs]). + +define_labels(Addr, [{'JUMPDEST', Lab}|More]) -> + [{Lab, Addr}|define_labels(Addr + 1, More)]; +define_labels(Addr, [{push_label, _}|More]) -> + define_labels(Addr + 4, More); +define_labels(Addr, [{pop_args, N}|More]) -> + define_labels(Addr + N + 1, More); +define_labels(Addr, [_|More]) -> + define_labels(Addr + 1, More); +define_labels(_, []) -> + []. + +use_labels(_, {'JUMPDEST', _}) -> + 'JUMPDEST'; +use_labels(Labels, {push_label, Ref}) -> + case proplists:get_value(Ref, Labels) of + undefined -> + gen_error({undefined_label, Ref}); + Addr when is_integer(Addr) -> + [i(?PUSH3), + Addr div 65536, (Addr div 256) rem 256, Addr rem 256] + end; +use_labels(_, {pop_args, N}) -> + [swap(N), pop(N)]; +use_labels(_, I) -> + I. + +%% Peep-hole optimization. +%% The compilation of conditionals can introduce jumps depending on +%% constants 1 and 0. These are removed by peep-hole optimization. + +peep_hole(['PUSH1', 0, {push_label, _}, 'JUMPI'|More]) -> + peep_hole(More); +peep_hole(['PUSH1', 1, {push_label, Lab}, 'JUMPI'|More]) -> + [{push_label, Lab}, 'JUMP'|peep_hole(More)]; +peep_hole([{pop_args, M}, {pop_args, N}|More]) when M + N =< 16 -> + peep_hole([{pop_args, M + N}|More]); +peep_hole([I|More]) -> + [I|peep_hole(More)]; +peep_hole([]) -> + []. + +%% Peep-hole optimization on reversed instructions lists. + +peep_hole_backwards(Code) -> + NewCode = peep_hole_backwards1(Code), + if Code == NewCode -> Code; + true -> peep_hole_backwards(NewCode) + end. + +peep_hole_backwards1(['ADD', 0, 'PUSH1'|Code]) -> + peep_hole_backwards1(Code); +peep_hole_backwards1(['POP', UnOp|Code]) when UnOp=='MLOAD';UnOp=='ISZERO';UnOp=='NOT' -> + peep_hole_backwards1(['POP'|Code]); +peep_hole_backwards1(['POP', BinOp|Code]) when + %% TODO: more binary operators + BinOp=='ADD';BinOp=='SUB';BinOp=='MUL';BinOp=='SDIV' -> + peep_hole_backwards1(['POP', 'POP'|Code]); +peep_hole_backwards1(['POP', _, 'PUSH1'|Code]) -> + peep_hole_backwards1(Code); +peep_hole_backwards1([I|Code]) -> + [I|peep_hole_backwards1(Code)]; +peep_hole_backwards1([]) -> + []. + +%% Jump optimization: +%% Replaces a jump to a jump with a jump to the final destination +%% Moves basic blocks to eliminate an unconditional jump to them. + +%% The compilation of conditionals generates a lot of labels and +%% jumps, some of them unnecessary. This optimization phase reorders +%% code so that as many jumps as possible can be eliminated, and +%% replaced by just falling through to the destination label. This +%% both optimizes the code generated by conditionals, and converts one +%% call of a function into falling through into its code--so it +%% reorders code quite aggressively. Function returns are indirect +%% jumps, however, and are never optimized away. + +%% IMPORTANT: since execution begins at address zero, then the first +%% block of code must never be moved elsewhere. The code below has +%% this property, because it processes blocks from left to right, and +%% because the first block does not begin with a label, and so can +%% never be jumped to--hence no code can be inserted before it. + +%% The optimization works by taking one block of code at a time, and +%% then prepending blocks that jump directly to it, and appending +%% blocks that it jumps directly to, resulting in a jump-free sequence +%% that is as long as possible. To do so, we store blocks in the form +%% {OptionalLabel, Body, OptionalJump} which represents the code block +%% OptionalLabel++Body++OptionalJump; the optional parts are the empty +%% list of instructions if not present. Two blocks can be merged if +%% the first ends in an OptionalJump to the OptionalLabel beginning +%% the second; the OptionalJump can then be removed (and the +%% OptionalLabel if there are no other references to it--this happens +%% during dead code elimination. + +%% TODO: the present implementation is QUADRATIC, because we search +%% repeatedly for matching blocks to merge with the first one, storing +%% the blocks in a list. A near linear time implementation could use +%% two ets tables, one keyed on the labels, and the other keyed on the +%% final jumps. + +optimize_jumps(Code) -> + JJs = jumps_to_jumps(Code), + ShortCircuited = [short_circuit_jumps(JJs, Instr) || Instr <- Code], + NoDeadCode = eliminate_dead_code(ShortCircuited), + MovedCode = merge_blocks(moveable_blocks(NoDeadCode)), + %% Moving code may have made some labels superfluous. + eliminate_dead_code(MovedCode). + + +jumps_to_jumps([{'JUMPDEST', Label}, {push_label, Target}, 'JUMP'|More]) -> + [{Label, Target}|jumps_to_jumps(More)]; +jumps_to_jumps([{'JUMPDEST', Label}, {'JUMPDEST', Target}|More]) -> + [{Label, Target}|jumps_to_jumps([{'JUMPDEST', Target}|More])]; +jumps_to_jumps([_|More]) -> + jumps_to_jumps(More); +jumps_to_jumps([]) -> + []. + +short_circuit_jumps(JJs, {push_label, Lab}) -> + case proplists:get_value(Lab, JJs) of + undefined -> + {push_label, Lab}; + Target -> + %% I wonder if this will ever loop infinitely? + short_circuit_jumps(JJs, {push_label, Target}) + end; +short_circuit_jumps(_JJs, Instr) -> + Instr. + +eliminate_dead_code(Code) -> + Jumps = lists:usort([Lab || {push_label, Lab} <- Code]), + NewCode = live_code(Jumps, Code), + if Code==NewCode -> + Code; + true -> + eliminate_dead_code(NewCode) + end. + +live_code(Jumps, ['JUMP'|More]) -> + ['JUMP'|dead_code(Jumps, More)]; +live_code(Jumps, ['STOP'|More]) -> + ['STOP'|dead_code(Jumps, More)]; +live_code(Jumps, [{'JUMPDEST', Lab}|More]) -> + case lists:member(Lab, Jumps) of + true -> + [{'JUMPDEST', Lab}|live_code(Jumps, More)]; + false -> + live_code(Jumps, More) + end; +live_code(Jumps, [I|More]) -> + [I|live_code(Jumps, More)]; +live_code(_, []) -> + []. + +dead_code(Jumps, [{'JUMPDEST', Lab}|More]) -> + case lists:member(Lab, Jumps) of + true -> + [{'JUMPDEST', Lab}|live_code(Jumps, More)]; + false -> + dead_code(Jumps, More) + end; +dead_code(Jumps, [_I|More]) -> + dead_code(Jumps, More); +dead_code(_, []) -> + []. + +%% Split the code into "moveable blocks" that control flow only +%% reaches via jumps. +moveable_blocks([]) -> + []; +moveable_blocks([I]) -> + [[I]]; +moveable_blocks([Jump|More]) when Jump=='JUMP'; Jump=='STOP' -> + [[Jump]|moveable_blocks(More)]; +moveable_blocks([I|More]) -> + [Block|MoreBlocks] = moveable_blocks(More), + [[I|Block]|MoreBlocks]. + +%% Merge blocks to eliminate jumps where possible. +merge_blocks(Blocks) -> + BlocksAndTargets = [label_and_jump(B) || B <- Blocks], + [I || {Pref, Body, Suff} <- merge_after(BlocksAndTargets), + I <- Pref++Body++Suff]. + +%% Merge the first block with other blocks that come after it +merge_after(All=[{Label, Body, [{push_label, Target}, 'JUMP']}|BlocksAndTargets]) -> + case [{B, J} || {[{'JUMPDEST', L}], B, J} <- BlocksAndTargets, + L == Target] of + [{B, J}|_] -> + merge_after([{Label, Body ++ [{'JUMPDEST', Target}] ++ B, J}| + lists:delete({[{'JUMPDEST', Target}], B, J}, + BlocksAndTargets)]); + [] -> + merge_before(All) + end; +merge_after(All) -> + merge_before(All). + +%% The first block cannot be merged with any blocks that it jumps +%% to... but maybe it can be merged with a block that jumps to it! +merge_before([Block={[{'JUMPDEST', Label}], Body, Jump}|BlocksAndTargets]) -> + case [{L, B, T} || {L, B, [{push_label, T}, 'JUMP']} <- BlocksAndTargets, + T == Label] of + [{L, B, T}|_] -> + merge_before([{L, B ++ [{'JUMPDEST', Label}] ++ Body, Jump} + |lists:delete({L, B, [{push_label, T}, 'JUMP']}, BlocksAndTargets)]); + _ -> + [Block | merge_after(BlocksAndTargets)] + end; +merge_before([Block|BlocksAndTargets]) -> + [Block | merge_after(BlocksAndTargets)]; +merge_before([]) -> + []. + +%% Convert each block to a PREFIX, which is a label or empty, a +%% middle, and a SUFFIX which is a JUMP to a label, or empty. +label_and_jump(B) -> + {Label, B1} = case B of + [{'JUMPDEST', L}|More1] -> + {[{'JUMPDEST', L}], More1}; + _ -> + {[], B} + end, + {Target, B2} = case lists:reverse(B1) of + ['JUMP', {push_label, T}|More2] -> + {[{push_label, T}, 'JUMP'], lists:reverse(More2)}; + _ -> + {[], B1} + end, + {Label, B2, Target}. diff --git a/src/aeso_memory.erl b/src/aeso_memory.erl new file mode 100644 index 0000000..6d6c203 --- /dev/null +++ b/src/aeso_memory.erl @@ -0,0 +1,19 @@ +%%%------------------------------------------------------------------- +%%% @copyright (C) 2018, Aeternity Anstalt +%%% @doc +%%% Memory speifics that compiler and VM need to agree upon +%%% @end +%%% Created : 19 Dec 2018 +%%%------------------------------------------------------------------- + +-module(aeso_memory). + +-export([binary_to_words/1]). + +binary_to_words(<<>>) -> + []; +binary_to_words(<>) -> + [N|binary_to_words(Bin)]; +binary_to_words(Bin) -> + binary_to_words(<>). + diff --git a/src/aeso_parse_lib.erl b/src/aeso_parse_lib.erl new file mode 100644 index 0000000..d1be781 --- /dev/null +++ b/src/aeso_parse_lib.erl @@ -0,0 +1,413 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2018, Aeternity Anstalt +%%% @doc Parser combinators for the Sophia parser. Based on +%%% Koen Claessen. 2004. Parallel Parsing Processes. J. Functional +%%% Programming 14, 6 (November 2004) +%%% @end +%%%------------------------------------------------------------------- +-module(aeso_parse_lib). + +-export([parse/2, + return/1, fail/0, fail/1, map/2, bind/2, + lazy/1, choice/1, choice/2, tok/1, layout/0, + left/2, right/2, between/3, optional/1, + many/1, many1/1, sep/2, sep1/2, + infixl/2, infixr/2]). + +%% -- Types ------------------------------------------------------------------ + +-export_type([parser/1, parser_expr/1, pos/0, token/0, tokens/0]). + +-type pos() :: {integer(), integer()}. +-type token() :: {atom(), pos(), term()} | {atom(), pos()}. +-type tokens() :: [token()]. +-type error() :: {pos(), string() | no_error}. + +-define(lazy(F), {aeso_parse_lazy, F}). +-define(fail(Err), {aeso_parse_fail, Err}). +-define(choice(Ps), {aeso_parse_choice, Ps}). +-define(bind(P, F), {aeso_parse_bind, P, F}). +-define(right(P, Q), {aeso_parse_right, P, Q}). +-define(left(P, Q), {aeso_parse_left, P, Q}). +-define(map(F, P), {aeso_parse_map, F, P}). +-define(layout, aeso_parse_layout). +-define(tok(Atom), {aeso_parse_tok, Atom}). +-define(return(X), {aeso_parse_return, X}). + +%% Type synonyms since you can't have function types as macro arguments for some reason. +-type delayed(A) :: fun(() -> A). +-type continuation(A, B) :: fun((A) -> parser(B)). +-type function(A, B) :: fun((A) -> B). + +%% The representation of parsers that the user writes. These get compiled down to a lower-level +%% representation before parsing (parser1/1). +-opaque parser_expr(A) + :: ?lazy(delayed(parser(A))) + | ?fail(term()) + | ?choice([parser(A)]) + | ?bind(parser(B), continuation(B, A)) + | ?map(function(B, A), parser(B)) + | ?left(parser(A), parser(A)) + | ?right(parser(A), parser(A)). + +%% Lists, tuples and maps of parsers are valid parsers. These are applied in left-to-right order and +%% a list/tuple/map is built out of the results. For maps only the values (and not the keys) can be +%% parsers. +-type parser(A) :: parser_expr(A) + | maybe_improper_list(parser(_), parser(_)) + | tuple() %% A = tuple() + | term(). %% Interpreted as a parser that returns the term without consuming input + +%% The low level parser representation. This is what's used when doing the +%% actual parsing (see parse1/2). +-type parser1(A) :: {tok_bind, #{atom() => fun((token()) -> parser1(A))}} + %% ^ Consume a token and dispatch on its tag. + | {fail, term()} + %% ^ Fail with the given error + | {return_plus, A, parser1(A)} + %% ^ Choice between returning a value and continue parsing + | {layout, fun((integer()) -> parser1(A)), parser1(A)}. + %% ^ Parse a layout block. If a layout block can be started, it commits to the + %% first argument. I.e. no backtracking to the second argument if the first + %% fails. + +%% Apply a parser to its continuation. This compiles a parser to its low-level representation. +-spec apply_p(parser(A), fun((A) -> parser1(B))) -> parser1(B). +apply_p(?lazy(F), K) -> apply_p(F(), K); +apply_p(?fail(Err), _) -> {fail, Err}; +apply_p(?choice([P | Ps]), K) -> lists:foldl(fun(Q, R) -> choice1(apply_p(Q, K), R) end, + apply_p(P, K), Ps); +apply_p(?bind(P, F), K) -> apply_p(P, fun(X) -> apply_p(F(X), K) end); +apply_p(?right(P, Q), K) -> apply_p(P, fun(_) -> apply_p(Q, K) end); +apply_p(?left(P, Q), K) -> apply_p(P, fun(X) -> apply_p(Q, fun(_) -> K(X) end) end); +apply_p(?map(F, P), K) -> apply_p(P, fun(X) -> K(F(X)) end); +apply_p(?layout, K) -> {layout, K, {fail, {expected, layout_block}}}; +apply_p(?tok(Atom), K) -> {tok_bind, #{Atom => K}}; +apply_p(?return(X), K) -> K(X); +apply_p([P | Q], K) -> apply_p(P, fun(H) -> apply_p(Q, fun(T) -> K([H | T]) end) end); +apply_p(T, K) when is_tuple(T) -> apply_p(tuple_to_list(T), fun(Xs) -> K(list_to_tuple(Xs)) end); +apply_p(M, K) when is_map(M) -> + {Keys, Ps} = lists:unzip(maps:to_list(M)), + apply_p(Ps, fun(Vals) -> K(maps:from_list(lists:zip(Keys, Vals))) end); +apply_p(X, K) -> K(X). + +%% -- Primitive combinators -------------------------------------------------- + +%% @doc Create a delayed parser. Required when building recursive parsers to avoid looping. +-spec lazy(fun(() -> parser(A))) -> parser(A). +lazy(Delayed) -> ?lazy(Delayed). + +%% @doc A parser that always fails. +-spec fail(term()) -> parser(none()). +fail(Err) -> ?fail(Err). + +%% @doc Fail with no error message. +-spec fail() -> parser(none()). +fail() -> fail(no_error). + +%% @doc A choice between two parsers. Succeeds if either parser succeeds. +-spec choice(parser(A), parser(A)) -> parser(A). +choice(?choice(Ps), ?choice(Qs)) -> ?choice(Ps ++ Qs); +choice(?choice(Ps), Q) -> ?choice([Q | Ps]); +choice(P, ?choice(Qs)) -> ?choice([P | Qs]); +choice(P, Q) -> ?choice([P, Q]). + +%% @doc A choice between a list of parsers. Applies 'choice/2' repeatedly. +-spec choice([parser(A)]) -> parser(A). +choice([]) -> fail(empty_choice); +choice([P]) -> P; +choice([P | Ps]) -> choice(P, choice(Ps)). + +%% @doc Parse a single token with the given tag. +-spec tok(atom()) -> parser(token()). +tok(Atom) -> ?tok(Atom). + +%% @doc Apply two parsers in sequence and return the result from the first one. +-spec left(parser(A), parser(_)) -> parser(A). +left(P, Q) -> ?left(P, Q). + +%% @doc Apply two parsers in sequence and return the result from the second one. +-spec right(parser(_), parser(A)) -> parser(A). +right(P, Q) -> ?right(P, Q). + +%% @doc A parser that always succeeds with the given value. +-spec return(A) -> parser(A). +return(X) -> ?return(X). + +%% @doc Monadic bind. Lets you inspect the result of the first parser before deciding on what to +%% parse next. +-spec bind(parser(A), fun((A) -> parser(B))) -> parser(B). +bind(?return(X), F) -> F(X); +bind(P, F) -> ?bind(P, F). + +%% @doc Apply a function to the result of a parser. +-spec map(fun((A) -> B), parser(A)) -> parser(B). +map(Fun, P) -> ?map(Fun, P). + +%% @doc Parse the start of a layout block. A layout block can start if the next token is not on the +%% same line as the previous token and it is indented further than the current layout block (if +%% any). The result is the column of the new layout block (i.e. the column of the next token). +-spec layout() -> parser(integer()). +layout() -> ?layout. + +%% @doc Parse a sequence of tokens using a parser. Fails if the parse is ambiguous. +-spec parse(parser(A), tokens()) -> {ok, A} | {error, term()}. +parse(P, S) -> + case parse1(apply_p(P, fun(X) -> {return_plus, X, {fail, no_error}} end), S) of + {[], {Pos, Err}} -> {error, {Pos, parse_error, flatten_error(Err)}}; + {[A], _} -> {ok, A}; + {As, _} -> {error, {{1, 1}, ambiguous_parse, As}} + end. + +-spec flatten_error(iolist() | no_error) -> string(). +flatten_error(no_error) -> "Unspecified error"; +flatten_error(Err) -> lists:flatten(Err). + +%% -- Derived combinators ---------------------------------------------------- + +%% @doc Parse zero or more A's. +-spec many(parser(A)) -> parser([A]). +many(P) -> choice([], many1(P)). + +-dialyzer({nowarn_function, many1/1}). %% Silence improper_list warning. +%% @doc Parse one or more A's. +-spec many1(parser(A)) -> parser([A]). +many1(P) -> [P | lazy(fun() -> many(P) end)]. + +%% @doc Parse zero or more A's, separated by Sep. +-spec sep(parser(A), parser(_)) -> parser([A]). +sep(P, Sep) -> choice([], sep1(P, Sep)). + +-dialyzer({nowarn_function, sep1/2}). %% Silence improper_list warning. +%% @doc Parse one or more A's, separated by Sep. +-spec sep1(parser(A), parser(_)) -> parser([A]). +sep1(P, Sep) -> [P | many(right(Sep, P))]. + +%% @doc Parse a left-associative operator.

+%% infixl(Elem, Op) ::= Elem | infixl(Elem, Op) Op Elem +%%

+-spec infixl(parser(A), parser(fun((A, A) -> A))) -> parser(A). +infixl(Elem, Op) -> + bind(Elem, fun(A) -> + bind(many({Op, Elem}), fun(Ops) -> + return(build_infixl(A, Ops)) end) end). + +%% @doc Parse a right-associative operator.

+%% infixr(Elem, Op) ::= Elem | Elem Op infixl(Elem, Op) +%%

+-spec infixr(parser(A), parser(fun((A, A) -> A))) -> parser(A). +infixr(Elem, Op) -> + bind(Elem, fun(A) -> + bind(many({Op, Elem}), fun(Ops) -> + return(build_infixr(A, Ops)) end) end). + +build_infixl(A, []) -> A; +build_infixl(A, [{Op, B} | Ops]) -> build_infixl(Op(A, B), Ops). + +build_infixr(A, []) -> A; +build_infixr(A, [{Op, B} | Ops]) -> Op(A, build_infixr(B, Ops)). + +%% @doc Parse an A between two other things (typically brackets of some kind). +-spec between(parser(_), parser(A), parser(_)) -> parser(A). +between(L, P, R) -> + right(L, left(P, R)). + +-spec optional(parser(A)) -> parser(none | {ok, A}). +optional(P) -> choice(none, {ok, P}). + +%% -- Internal functions ----------------------------------------------------- + +-spec tag(token()) -> atom(). +tag(T) when is_tuple(T) -> element(1, T). + +-spec pos(token()) -> pos(). +pos(T) when is_tuple(T) -> element(2, T). + +-spec line(token()) -> integer(). +line(T) when is_tuple(T) -> element(1, pos(T)). + +-spec col(token()) -> integer(). +col(T) when is_tuple(T) -> element(2, pos(T)). + +%% Choice on low-level parsers. +-spec choice1(parser1(A), parser1(A)) -> parser1(A). + +%% If both parsers want the next token we grab it and merge the continuations. +choice1({tok_bind, Map1}, {tok_bind, Map2}) -> + {tok_bind, merge_with(fun(F, G) -> fun(T) -> choice1(F(T), G(T)) end end, Map1, Map2)}; + +%% If both parsers fail we combine the error messages. If only one fails we discard it. +choice1({fail, E1}, {fail, E2}) -> {fail, add_error(E1, E2)}; +choice1({fail, _}, Q) -> Q; +choice1(P, {fail, _}) -> P; + +%% If either side can deliver a value, then so can the choice. +choice1({return_plus, X, P}, Q) -> {return_plus, X, choice1(P, Q)}; +choice1(P, {return_plus, X, Q}) -> {return_plus, X, choice1(P, Q)}; + +%% If both sides want a layout block we combine them. If only one side wants a layout block we +%% will commit to a layout block is there is one. +choice1({layout, F, P}, {layout, G, Q}) -> + {layout, fun(N) -> choice1(F(N), G(N)) end, choice1(P, Q)}; +choice1({layout, F, P}, Q) -> {layout, F, choice1(P, Q)}; +choice1(P, {layout, G, Q}) -> {layout, G, choice1(P, Q)}. + +%% Token stream representation. This is the state of the parse function. +-record(ts, {layout :: [integer()], %% Column numbers of the current layout blocks. + last :: token(), %% The previously consumed token. + inserted :: tokens(), %% Inserted layout tokens, consumed before 'tokens'. + tokens :: tokens()}). %% The remaining tokens to be parsed. + +%% The initial token stream. +ts(S) -> + #ts{ layout = [], last = {bof, {0, 0}}, inserted = [], tokens = S }. + +%% The parse function. Parses a token stream returning a list of results and an error message in +%% case of failure. +-spec parse1(parser1(A), tokens()) -> {[A], term()}. +parse1(P, S) -> + parse1(P, ts(S), [], no_error). + +%% The main work horse. Returns a list of possible parses and an error message in case parsing +%% fails. +-spec parse1(parser1(A), #ts{}, [A], term()) -> {[A], error()}. +parse1({tok_bind, Map}, Ts, Acc, Err) -> + case next_token(Ts) of + {T, Ts1} -> + case maps:get(tag(T), Map, '$not_found') of + '$not_found' -> + %% Insert a vclose (if required) on unexpected tokens. This lets you have layout + %% blocks inside parens without having to put the closing paren on a separate + %% line. Example: + %% ((x) => + %% let y = x + 1 + %% y + y)(4) + case maps:get(vclose, Map, '$not_found') of + '$not_found' -> + {Acc, unexpected_token_error(Ts, T)}; + F -> + VClose = {vclose, pos(T)}, + Ts2 = pop_layout(VClose, Ts#ts{ last = VClose }), + parse1(F(VClose), Ts2, Acc, Err) + end; + F -> parse1(F(T), Ts1, Acc, Err) + end; + false -> + {Acc, mk_error(Ts, io_lib:format("Unexpected end of file. Expected one of ~p.", + [maps:keys(Map)]))} + end; +parse1({layout, F, P}, Ts, Acc, Err) -> + case start_layout(Ts) of + {Col, Ts1} -> parse1(F(Col), Ts1, Acc, Err); + false -> parse1(P, Ts, Acc, mk_error(Ts, "Expected layout block.")) + end; +parse1({return_plus, X, P}, Ts, Acc, Err) -> + case next_token(Ts) of + false -> parse1(P, Ts, [X | Acc], Err); + {T, _} -> parse1(P, Ts, Acc, unexpected_token_error(Ts, T)) + end; +parse1({fail, Err}, Ts, Acc, Err1) -> + Err2 = case next_token(Ts) of + {T, _} -> unexpected_token_error(Ts, T); + _ -> no_error + end, + {Acc, add_error(add_error(mk_error(Ts, Err), Err2), Err1)}. + +%% Get the current position of the token stream. This is the position of the next token if any, and +%% the line after the last token if at the end of the stream. +-spec current_pos(#ts{}) -> pos(). +current_pos(#ts{ inserted = [T | _] }) -> pos(T); +current_pos(#ts{ tokens = [T | _] }) -> pos(T); +current_pos(#ts{ last = T }) -> end_pos(pos(T)). + +-spec mk_error(#ts{}, term()) -> error(). +mk_error(Ts, Err) -> + {current_pos(Ts), Err}. + +-spec unexpected_token_error(#ts{}, token()) -> error(). +unexpected_token_error(Ts, T) -> + mk_error(Ts, io_lib:format("Unexpected token ~p", [tag(T)])). + +%% Get the next token from a token stream. Inserts layout tokens if necessary. +-spec next_token(#ts{}) -> false | {token(), #ts{}}. +next_token(Ts) -> + case insert_layout_tokens(Ts) of + Ts1 = #ts{ inserted = [L | Ls] } -> {L, pop_layout(L, Ts1#ts{ last = L, inserted = Ls })}; + Ts1 = #ts{ tokens = [T | S] } -> {T, Ts1#ts{ last = T, tokens = S }}; + #ts{ inserted = [], tokens = [] } -> false + end. + +%% Pop a layout block on an inserted 'vclose' token. +-spec pop_layout(token(), #ts{}) -> #ts{}. +pop_layout({vclose, _}, Ts = #ts{ layout = [_ | Layout] }) -> Ts#ts{ layout = Layout }; +pop_layout(_, Ts) -> Ts. + +%% Attempt to start a new layout block. Requires the next token to be on a new line and indented +%% more than any existing layout block. Sets the previous token to 'vopen'. +-spec start_layout(#ts{}) -> false | {integer(), #ts{}}. +start_layout(#ts{ inserted = [_ | _] }) -> false; %% Can't start a layout block before consuming all layout tokens +start_layout(#ts{ tokens = [] }) -> false; %% No more tokens +start_layout(Ts = #ts{ layout = Layout, last = Last, tokens = [T | _] }) -> + Col = col(T), + Valid = case Layout of + [] -> line(Last) < line(T); + [C1 | _] -> line(Last) < line(T) andalso C1 < Col + end, + Valid andalso {Col, Ts#ts{ layout = [Col | Layout], last = {vopen, pos(T)} }}. + +%% Insert layout tokens. If the next token is on the same line as the current layout block we insert +%% a 'vsemi' token. If the next token is indented less, we insert a 'vclose' token. +-spec insert_layout_tokens(#ts{}) -> #ts{}. +insert_layout_tokens(Ts = #ts{ inserted = [_ | _] }) -> + Ts; %% already inserted layout tokens +insert_layout_tokens(Ts = #ts{ layout = Layout, last = Last, tokens = S }) -> + ToInsert = insert_layout_tokens(Layout, Last, S, []), + Ts#ts{ inserted = ToInsert }. + +%% Compute the layout tokens to be inserted. +-spec insert_layout_tokens([integer()], token(), tokens(), tokens()) -> tokens(). +insert_layout_tokens([_ | Layout], Last, [], Acc) -> + %% End of the file. Insert vclose tokens for all layout blocks. + Vclose = {vclose, end_pos(pos(Last))}, + insert_layout_tokens(Layout, Last, [], [Vclose | Acc]); +insert_layout_tokens([N | Layout1], Last, S = [T | _], Acc) -> + Col = col(T), + %% Don't insert a vsemi if the previous token was a vopen or a vsemi. The former to avoid a + %% vsemi for the first token of the block and the latter to avoid inserting infinite vsemis. + AlreadySemi = lists:member(tag(Last), [vsemi, vopen]) andalso col(Last) == N, + if Col == N, not AlreadySemi -> + lists:reverse([{vsemi, pos(T)} | Acc]); + Col < N -> + Vclose = {vclose, pos(T)}, + insert_layout_tokens(Layout1, Vclose, S, [Vclose | Acc]); + true -> + lists:reverse(Acc) + end; +insert_layout_tokens([], _Last, _S, Acc) -> + lists:reverse(Acc). + +%% The end-of-file position. Beginning of the line after the last token. +end_pos({L, _}) -> {L + 1, 1}. + +%% Combine two error messages. Discard no_error's otherwise pick the first error. +add_error(no_error, Err) -> Err; +add_error({_, no_error}, Err) -> Err; +add_error(Err, no_error) -> Err; +add_error(Err, {_, no_error}) -> Err; +add_error(Err, _Err1) -> Err. + +%% For some unfathomable reason the maps module does not have a merge_with function. +-spec merge_with(fun((term(), term()) -> term()), map(), map()) -> map(). +merge_with(Fun, Map1, Map2) -> + case maps:size(Map1) > maps:size(Map2) of + true -> + lists:foldl(fun({K, R}, M) -> + maps:update_with(K, fun(L) -> Fun(L, R) end, R, M) + end, Map1, maps:to_list(Map2)); + false -> + lists:foldl(fun({K, L}, M) -> + maps:update_with(K, fun(R) -> Fun(L, R) end, L, M) + end, Map2, maps:to_list(Map1)) + end. + diff --git a/src/aeso_parse_lib.hrl b/src/aeso_parse_lib.hrl new file mode 100644 index 0000000..6930d12 --- /dev/null +++ b/src/aeso_parse_lib.hrl @@ -0,0 +1,25 @@ + +-define(LET_P(X, P, Q), aeso_parse_lib:bind(P, fun(X) -> Q end)). +-define(LAZY_P(P), aeso_parse_lib:lazy(fun() -> P end)). +-define(MEMO_P(P), aeso_parse_lib:lazy(aeso_parse_lib:memoised(fun() -> P end))). + +-define(GUARD_P(G, P), + case G of + true -> P; + false -> fail() + end). + +-define(RULE(A, Do), map(fun(_1) -> Do end, A )). +-define(RULE(A, B, Do), map(fun({_1, _2}) -> Do end, {A, B} )). +-define(RULE(A, B, C, Do), map(fun({_1, _2, _3}) -> Do end, {A, B, C} )). +-define(RULE(A, B, C, D, Do), map(fun({_1, _2, _3, _4}) -> Do end, {A, B, C, D} )). +-define(RULE(A, B, C, D, E, Do), map(fun({_1, _2, _3, _4, _5}) -> Do end, {A, B, C, D, E} )). +-define(RULE(A, B, C, D, E, F, Do), map(fun({_1, _2, _3, _4, _5, _6}) -> Do end, {A, B, C, D, E, F})). + +-import(aeso_parse_lib, + [tok/1, tok/2, between/3, many/1, many1/1, sep/2, sep1/2, + infixl/1, infixr/1, choice/1, choice/2, return/1, layout/0, + fail/0, fail/1, map/2, infixl/2, infixr/2, infixl1/2, infixr1/2, + left/2, right/2, optional/1]). + + diff --git a/src/aeso_parser.erl b/src/aeso_parser.erl new file mode 100644 index 0000000..f84295e --- /dev/null +++ b/src/aeso_parser.erl @@ -0,0 +1,457 @@ +%%% File : aeso_parser.erl +%%% Author : Ulf Norell +%%% Description : +%%% Created : 1 Mar 2018 by Ulf Norell +-module(aeso_parser). + +-export([string/1, + type/1]). + +-include("aeso_parse_lib.hrl"). + +-spec string(string()) -> + {ok, aeso_syntax:ast()} + | {error, {aeso_parse_lib:pos(), + atom(), + term()}} + | {error, {aeso_parse_lib:pos(), + atom()}}. +string(String) -> + parse_and_scan(file(), String). + +type(String) -> + parse_and_scan(type(), String). + +parse_and_scan(P, S) -> + case aeso_scan:scan(S) of + {ok, Tokens} -> aeso_parse_lib:parse(P, Tokens); + Error -> Error + end. + +%% -- Parsing rules ---------------------------------------------------------- + +file() -> choice([], block(decl())). + +decl() -> + ?LAZY_P( + choice( + %% Contract declaration + [ ?RULE(keyword(contract), con(), tok('='), maybe_block(decl()), {contract, _1, _2, _4}) + + %% Type declarations TODO: format annotation for "type bla" vs "type bla()" + , ?RULE(keyword(type), id(), {type_decl, _1, _2, []}) + , ?RULE(keyword(type), id(), type_vars(), {type_decl, _1, _2, _3}) + , ?RULE(keyword(type), id(), tok('='), typedef(type), {type_def, _1, _2, [], _4}) + , ?RULE(keyword(type), id(), type_vars(), tok('='), typedef(type), {type_def, _1, _2, _3, _5}) + , ?RULE(keyword(record), id(), tok('='), typedef(record), {type_def, _1, _2, [], _4}) + , ?RULE(keyword(record), id(), type_vars(), tok('='), typedef(record), {type_def, _1, _2, _3, _5}) + , ?RULE(keyword(datatype), id(), tok('='), typedef(variant), {type_def, _1, _2, [], _4}) + , ?RULE(keyword(datatype), id(), type_vars(), tok('='), typedef(variant), {type_def, _1, _2, _3, _5}) + + %% Function declarations + , ?RULE(modifiers(), keyword(function), id(), tok(':'), type(), add_modifiers(_1, {fun_decl, _2, _3, _5})) + , ?RULE(modifiers(), keyword(function), fundef(), add_modifiers(_1, set_pos(get_pos(_2), _3))) + , ?RULE(keyword('let'), valdef(), set_pos(get_pos(_1), _2)) + ])). + +modifiers() -> + many(choice([token(stateful), token(public), token(private), token(internal)])). + +add_modifiers(Mods, Node) -> + lists:foldl(fun({Mod, _}, X) -> set_ann(Mod, true, X) end, + Node, Mods). + +%% -- Type declarations ------------------------------------------------------ + +typedef(type) -> ?RULE(type(), {alias_t, _1}); +typedef(record) -> ?RULE(brace_list(field_type()), {record_t, _1}); +typedef(variant) -> ?RULE(constructors(), {variant_t, _1}). + +constructors() -> + sep1(constructor(), tok('|')). + +constructor() -> %% TODO: format for Con() vs Con + choice(?RULE(con(), {constr_t, get_ann(_1), _1, []}), + ?RULE(con(), con_args(), {constr_t, get_ann(_1), _1, _2})). + +con_args() -> paren_list(con_arg()). +type_args() -> paren_list(type()). +field_type() -> ?RULE(id(), tok(':'), type(), {field_t, get_ann(_1), _1, _3}). + +con_arg() -> choice(type(), ?RULE(keyword(indexed), type(), set_ann(indexed, true, _2))). + +%% -- Let declarations ------------------------------------------------------- + +letdecl() -> + choice( + ?RULE(keyword('let'), letdef(), set_pos(get_pos(_1), _2)), + ?RULE(keyword('let'), tok(rec), sep1(letdef(), tok('and')), {letrec, _1, _3})). + +letdef() -> choice(valdef(), fundef()). + +valdef() -> + choice( + ?RULE(id(), tok('='), body(), {letval, [], _1, type_wildcard(), _3}), + ?RULE(id(), tok(':'), type(), tok('='), body(), {letval, [], _1, _3, _5})). + +fundef() -> + choice( + [ ?RULE(id(), args(), tok('='), body(), {letfun, [], _1, _2, type_wildcard(), _4}) + , ?RULE(id(), args(), tok(':'), type(), tok('='), body(), {letfun, [], _1, _2, _4, _6}) + ]). + +args() -> paren_list(arg()). + +arg() -> choice( + ?RULE(id(), {arg, get_ann(_1), _1, type_wildcard()}), + ?RULE(id(), tok(':'), type(), {arg, get_ann(_1), _1, _3})). + +%% -- Types ------------------------------------------------------------------ + +type_vars() -> paren_list(tvar()). + +type() -> ?LAZY_P(type100()). + +type100() -> type200(). + +type200() -> + ?RULE(many({fun_domain(), keyword('=>')}), type300(), fun_t(_1, _2)). + +type300() -> type400(). + +type400() -> + ?RULE(typeAtom(), optional(type_args()), + case _2 of + none -> _1; + {ok, Args} -> {app_t, get_ann(_1), _1, Args} + end). + +typeAtom() -> + ?LAZY_P(choice( + [ id(), token(con), token(qcon), token(qid), tvar() + , ?RULE(keyword('('), comma_sep(type()), tok(')'), tuple_t(_1, _2)) + ])). + +fun_domain() -> ?RULE(?LAZY_P(type300()), fun_domain(_1)). + +%% -- Statements ------------------------------------------------------------- + +body() -> + ?LET_P(Stmts, maybe_block(stmt()), block_e(Stmts)). + +stmt() -> + ?LAZY_P(choice( + [ expr() + , letdecl() + , {switch, keyword(switch), parens(expr()), maybe_block(branch())} + , {'if', keyword('if'), parens(expr()), body()} + , {elif, keyword(elif), parens(expr()), body()} + , {else, keyword(else), body()} + ])). + +branch() -> + ?RULE(pattern(), keyword('=>'), body(), {'case', _2, _1, _3}). + +pattern() -> + ?LET_P(E, expr500(), parse_pattern(E)). + +%% -- Expressions ------------------------------------------------------------ + +expr() -> expr100(). + +expr100() -> + Expr100 = ?LAZY_P(expr100()), + Expr200 = ?LAZY_P(expr200()), + choice( + [ ?RULE(args(), keyword('=>'), body(), {lam, _2, _1, _3}) %% TODO: better location + , {'if', keyword('if'), parens(Expr100), Expr200, right(tok(else), Expr100)} + , ?RULE(Expr200, optional(right(tok(':'), type())), + case _2 of + none -> _1; + {ok, Type} -> {typed, get_ann(_1), _1, Type} + end) + ]). + +expr200() -> infixr(expr300(), binop('||')). +expr300() -> infixr(expr400(), binop('&&')). +expr400() -> infix(expr500(), binop(['<', '>', '=<', '>=', '==', '!='])). +expr500() -> infixr(expr600(), binop(['::', '++'])). +expr600() -> infixl(expr650(), binop(['+', '-', 'bor', 'bxor', 'bsr', 'bsl'])). +expr650() -> ?RULE(many(token('-')), expr700(), prefixes(_1, _2)). +expr700() -> infixl(expr750(), binop(['*', '/', mod, 'band'])). +expr750() -> infixl(expr800(), binop(['^'])). +expr800() -> ?RULE(many(choice(token('!'), token('bnot'))), expr900(), prefixes(_1, _2)). +expr900() -> ?RULE(exprAtom(), many(elim()), elim(_1, _2)). + +exprAtom() -> + ?LAZY_P(begin + Expr = ?LAZY_P(expr()), + choice( + [ id(), con(), token(qid), token(qcon) + , token(hash), token(string), token(char) + , token(int) + , ?RULE(token(hex), set_ann(format, hex, setelement(1, _1, int))) + , {bool, keyword(true), true} + , {bool, keyword(false), false} + , ?RULE(brace_list(?LAZY_P(field_assignment())), record(_1)) + , {list, [], bracket_list(Expr)} + , ?RULE(tok('['), Expr, binop('..'), Expr, tok(']'), _3(_2, _4)) + , ?RULE(keyword('('), comma_sep(Expr), tok(')'), tuple_e(_1, _2)) + ]) + end). + +arg_expr() -> + ?LAZY_P( + choice([ ?RULE(id(), tok('='), expr(), {named_arg, [], _1, _3}) + , expr() ])). + +elim() -> + ?LAZY_P( + choice( + [ {proj, keyword('.'), id()} + , ?RULE(paren_list(arg_expr()), {app, [], _1}) + , ?RULE(keyword('{'), comma_sep(field_assignment()), tok('}'), {rec_upd, _1, _2}) + , ?RULE(keyword('['), map_key(), keyword(']'), map_get(_1, _2)) + ])). + +map_get(Ann, {map_key, Key}) -> {map_get, Ann, Key}; +map_get(Ann, {map_key, Key, Val}) -> {map_get, Ann, Key, Val}. + +map_key() -> + ?RULE(expr(), optional({tok('='), expr()}), map_key(_1, _2)). + +map_key(Key, none) -> {map_key, Key}; +map_key(Key, {ok, {_, Val}}) -> {map_key, Key, Val}. + +elim(E, []) -> E; +elim(E, [{proj, Ann, P} | Es]) -> elim({proj, Ann, E, P}, Es); +elim(E, [{app, Ann, Args} | Es]) -> elim({app, Ann, E, Args}, Es); +elim(E, [{rec_upd, Ann, Flds} | Es]) -> elim(record_update(Ann, E, Flds), Es); +elim(E, [{map_get, Ann, Key} | Es]) -> elim({map_get, Ann, E, Key}, Es); +elim(E, [{map_get, Ann, Key, Val} | Es]) -> elim({map_get, Ann, E, Key, Val}, Es). + +record_update(Ann, E, Flds) -> + {record_or_map(Flds), Ann, E, Flds}. + +record([]) -> {map, [], []}; +record(Fs) -> + case record_or_map(Fs) of + record -> {record, get_ann(hd(Fs)), Fs}; + map -> + Ann = get_ann(hd(Fs ++ [{empty, []}])), %% TODO: source location for empty maps + KV = fun({field, _, [{map_get, _, Key}], Val}) -> {Key, Val}; + ({field, _, LV, Id, _}) -> + bad_expr_err("Cannot use '@' in map construction", infix(LV, {op, Ann, '@'}, Id)); + ({field, _, LV, _}) -> + bad_expr_err("Cannot use nested fields or keys in map construction", LV) end, + {map, Ann, lists:map(KV, Fs)} + end. + +record_or_map(Fields) -> + Kind = fun(Fld) -> case element(3, Fld) of + [{proj, _, _} | _] -> proj; + [{map_get, _, _} | _] -> map_get; + [{map_get, _, _, _} | _] -> map_get + end end, + case lists:usort(lists:map(Kind, Fields)) of + [proj] -> record; + [map_get] -> map; + _ -> + [{field, Ann, _, _} | _] = Fields, + bad_expr_err("Mixed record fields and map keys in", {record, Ann, Fields}) + end. + +field_assignment() -> + ?RULE(lvalue(), optional({tok('@'), id()}), tok('='), expr(), field_assignment(get_ann(_3), _1, _2, _4)). + +field_assignment(Ann, LV, none, E) -> + {field, Ann, LV, E}; +field_assignment(Ann, LV, {ok, {_, Id}}, E) -> + {field, Ann, LV, Id, E}. + +lvalue() -> + ?RULE(lvalueAtom(), many(elim()), lvalue(elim(_1, _2))). + +lvalueAtom() -> + ?LAZY_P(choice([ id() + , ?RULE(keyword('['), map_key(), keyword(']'), _2) + ])). + +lvalue(E) -> lvalue(E, []). + +lvalue(X = {id, Ann, _}, LV) -> [{proj, Ann, X} | LV]; +lvalue({map_key, K}, LV) -> [{map_get, get_ann(K), K} | LV]; +lvalue({map_key, K, V}, LV) -> [{map_get, get_ann(K), K, V} | LV]; +lvalue({proj, Ann, E, P}, LV) -> lvalue(E, [{proj, Ann, P} | LV]); +lvalue({map_get, Ann, E, K}, LV) -> lvalue(E, [{map_get, Ann, K} | LV]); +lvalue({map_get, Ann, E, K, V}, LV) -> lvalue(E, [{map_get, Ann, K, V} | LV]); +lvalue(E, _) -> bad_expr_err("Not a valid lvalue", E). + +infix(E, Op) -> + ?RULE(E, optional({Op, E}), + case _2 of + none -> _1; + {ok, {F, Arg}} -> F(_1, Arg) + end). + +binop(Op) when is_atom(Op) -> binop([Op]); +binop(Ops) -> + ?RULE(choice([ token(Op) || Op <- Ops ]), fun(A, B) -> infix(A, _1, B) end). + +con() -> token(con). +id() -> token(id). +tvar() -> token(tvar). + +token(Tag) -> + ?RULE(tok(Tag), + case _1 of + {Tok, {Line, Col}} -> {Tok, pos_ann(Line, Col)}; + {Tok, {Line, Col}, Val} -> {Tok, pos_ann(Line, Col), Val} + end). + +%% -- Helpers ---------------------------------------------------------------- + +keyword(K) -> ann(tok(K)). +ann(P) -> map(fun get_ann/1, P). + +block(P) -> + between(layout(), sep1(P, tok(vsemi)), tok(vclose)). + +maybe_block(P) -> + choice(block(P), [P]). + +parens(P) -> between(tok('('), P, tok(')')). +braces(P) -> between(tok('{'), P, tok('}')). +brackets(P) -> between(tok('['), P, tok(']')). +comma_sep(P) -> sep(P, tok(',')). + +paren_list(P) -> parens(comma_sep(P)). +brace_list(P) -> braces(comma_sep(P)). +bracket_list(P) -> brackets(comma_sep(P)). + +%% -- Annotations ------------------------------------------------------------ + +-type ann() :: aeso_syntax:ann(). +-type ann_line() :: aeso_syntax:ann_line(). +-type ann_col() :: aeso_syntax:ann_col(). + +-spec pos_ann(ann_line(), ann_col()) -> ann(). +pos_ann(Line, Col) -> [{line, Line}, {col, Col}]. + +ann_pos(Ann) -> + {proplists:get_value(line, Ann), + proplists:get_value(col, Ann)}. + +get_ann(Ann) when is_list(Ann) -> Ann; +get_ann(Node) -> + case element(2, Node) of + {Line, Col} when is_integer(Line), is_integer(Col) -> pos_ann(Line, Col); + Ann -> Ann + end. + +get_ann(Key, Node) -> + proplists:get_value(Key, get_ann(Node)). + +set_ann(Key, Val, Node) -> + Ann = get_ann(Node), + setelement(2, Node, lists:keystore(Key, 1, Ann, {Key, Val})). + +get_pos(Node) -> + {get_ann(line, Node), get_ann(col, Node)}. + +set_pos({L, C}, Node) -> + set_ann(line, L, set_ann(col, C, Node)). + +infix(L, Op, R) -> set_ann(format, infix, {app, get_ann(L), Op, [L, R]}). + +prefixes(Ops, E) -> lists:foldr(fun prefix/2, E, Ops). +prefix(Op, E) -> set_ann(format, prefix, {app, get_ann(Op), Op, [E]}). + +type_wildcard() -> + {id, [{origin, system}], "_"}. + +block_e(Stmts) -> + group_ifs(Stmts, []). + +group_ifs([], [Stmt]) -> return(Stmt); +group_ifs([], Acc) -> + Stmts = [Stmt | _] = lists:reverse(Acc), + {block, get_ann(Stmt), Stmts}; +group_ifs([{'if', Ann, Cond, Then} | Stmts], Acc) -> + {Elses, Rest} = else_branches(Stmts, []), + group_ifs(Rest, [build_if(Ann, Cond, Then, Elses) | Acc]); +group_ifs([{else, Ann, _} | _], _) -> + fail({Ann, "No matching 'if' for 'else'"}); +group_ifs([{elif, Ann, _, _} | _], _) -> + fail({Ann, "No matching 'if' for 'elif'"}); +group_ifs([Stmt | Stmts], Acc) -> + group_ifs(Stmts, [Stmt | Acc]). + +build_if(Ann, Cond, Then, [{elif, Ann1, Cond1, Then1} | Elses]) -> + {'if', Ann, Cond, Then, + set_ann(format, elif, build_if(Ann1, Cond1, Then1, Elses))}; +build_if(Ann, Cond, Then, [{else, _Ann, Else}]) -> + {'if', Ann, Cond, Then, Else}; +build_if(Ann, Cond, Then, []) -> + {'if', Ann, Cond, Then, {unit, [{origin, system}]}}. + +else_branches([Elif = {elif, _, _, _} | Stmts], Acc) -> + else_branches(Stmts, [Elif | Acc]); +else_branches([Else = {else, _, _} | Stmts], Acc) -> + {lists:reverse([Else | Acc]), Stmts}; +else_branches(Stmts, Acc) -> + {lists:reverse(Acc), Stmts}. + +tuple_t(_Ann, [Type]) -> Type; %% Not a tuple +tuple_t(Ann, Types) -> {tuple_t, Ann, Types}. + +fun_t(Domains, Type) -> + lists:foldr(fun({Dom, Ann}, T) -> {fun_t, Ann, [], Dom, T} end, + Type, Domains). + +tuple_e(Ann, []) -> {unit, Ann}; +tuple_e(_Ann, [Expr]) -> Expr; %% Not a tuple +tuple_e(Ann, Exprs) -> {tuple, Ann, Exprs}. + +%% TODO: not nice +fun_domain({tuple_t, _, Args}) -> Args; +fun_domain(T) -> [T]. + +-spec parse_pattern(aeso_syntax:expr()) -> aeso_parse_lib:parser(aeso_syntax:pat()). +parse_pattern({app, Ann, Con = {'::', _}, Es}) -> + {app, Ann, Con, lists:map(fun parse_pattern/1, Es)}; +parse_pattern({app, Ann, Con = {con, _, _}, Es}) -> + {app, Ann, Con, lists:map(fun parse_pattern/1, Es)}; +parse_pattern({tuple, Ann, Es}) -> + {tuple, Ann, lists:map(fun parse_pattern/1, Es)}; +parse_pattern({list, Ann, Es}) -> + {list, Ann, lists:map(fun parse_pattern/1, Es)}; +parse_pattern({record, Ann, Fs}) -> + {record, Ann, lists:map(fun parse_field_pattern/1, Fs)}; +parse_pattern(E = {con, _, _}) -> E; +parse_pattern(E = {id, _, _}) -> E; +parse_pattern(E = {unit, _}) -> E; +parse_pattern(E = {int, _, _}) -> E; +parse_pattern(E = {bool, _, _}) -> E; +parse_pattern(E = {hash, _, _}) -> E; +parse_pattern(E = {string, _, _}) -> E; +parse_pattern(E = {char, _, _}) -> E; +parse_pattern(E) -> bad_expr_err("Not a valid pattern", E). + +-spec parse_field_pattern(aeso_syntax:field(aeso_syntax:expr())) -> aeso_parse_lib:parser(aeso_syntax:field(aeso_syntax:pat())). +parse_field_pattern({field, Ann, F, E}) -> + {field, Ann, F, parse_pattern(E)}. + +return_error({L, C}, Err) -> + fail(io_lib:format("~p:~p:\n~s", [L, C, Err])). + +-spec ret_doc_err(ann(), prettypr:document()) -> no_return(). +ret_doc_err(Ann, Doc) -> + return_error(ann_pos(Ann), prettypr:format(Doc)). + +-spec bad_expr_err(string(), aeso_syntax:expr()) -> no_return(). +bad_expr_err(Reason, E) -> + ret_doc_err(get_ann(E), + prettypr:sep([prettypr:text(Reason ++ ":"), + prettypr:nest(2, aeso_pretty:expr(E))])). + diff --git a/src/aeso_pretty.erl b/src/aeso_pretty.erl new file mode 100644 index 0000000..3462a2e --- /dev/null +++ b/src/aeso_pretty.erl @@ -0,0 +1,441 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc Pretty printer for Sophia. +%%% +%%% @end +%%%------------------------------------------------------------------- +-module(aeso_pretty). + +-import(prettypr, [text/1, sep/1, above/2, beside/2, nest/2, empty/0]). + +-export([decls/1, decls/2, decl/1, decl/2, expr/1, expr/2, type/1, type/2]). + +-export_type([options/0]). + +-type doc() :: prettypr:document(). +-type options() :: [{indent, non_neg_integer()} | show_generated]. + +%% More options: +%% Newline before open curly +%% Space before ':' + +%% -- Options ---------------------------------------------------------------- + +-define(aeso_pretty_opts, aeso_pretty_opts). + +-spec options() -> options(). +options() -> + case get(?aeso_pretty_opts) of + undefined -> []; + Opts -> Opts + end. + +-spec option(atom(), any()) -> any(). +option(Key, Default) -> + proplists:get_value(Key, options(), Default). + +-spec show_generated() -> boolean(). +show_generated() -> option(show_generated, false). + +-spec indent() -> non_neg_integer(). +indent() -> option(indent, 2). + +-spec with_options(options(), fun(() -> A)) -> A. +with_options(Options, Fun) -> + put(?aeso_pretty_opts, Options), + Res = Fun(), + erase(?aeso_pretty_opts), + Res. + +%% -- Pretty printing helpers ------------------------------------------------ + +-spec par([doc()]) -> doc(). +par(Ds) -> par(Ds, indent()). + +-spec par([doc()], non_neg_integer()) -> doc(). +par([], _) -> empty(); +par(Ds, N) -> prettypr:par(Ds, N). + +-spec follow(doc(), doc(), non_neg_integer()) -> doc(). +follow(A, B, N) -> + sep([A, nest(N, B)]). + +-spec follow(doc(), doc()) -> doc(). +follow(A, B) -> follow(A, B, indent()). + +-spec above([doc()]) -> doc(). +above([]) -> empty(); +above([D]) -> D; +above([D | Ds]) -> lists:foldl(fun(X, Y) -> above(Y, X) end, D, Ds). + +-spec beside([doc()]) -> doc(). +beside([]) -> empty(); +beside([D]) -> D; +beside([D | Ds]) -> lists:foldl(fun(X, Y) -> beside(Y, X) end, D, Ds). + +-spec hsep([doc()]) -> doc(). +hsep(Ds) -> beside(punctuate(text(" "), [ D || D <- Ds, D /= empty() ])). + +-spec hsep(doc(), doc()) -> doc(). +hsep(D1, D2) -> hsep([D1, D2]). + +-spec punctuate(doc(), [doc()]) -> [doc()]. +punctuate(_Sep, []) -> []; +punctuate(_Sep, [D]) -> [D]; +punctuate(Sep, [D | Ds]) -> [beside(D, Sep) | punctuate(Sep, Ds)]. + +-spec paren(doc()) -> doc(). +paren(D) -> beside([text("("), D, text(")")]). + +-spec paren(boolean(), doc()) -> doc(). +paren(false, D) -> D; +paren(true, D) -> paren(D). + +-spec indent(doc()) -> doc(). +indent(D) -> nest(indent(), D). + +%% block(Header, Body) -> +%% Header +%% Body +-spec block(doc(), doc()) -> doc(). +block(Header, Body) -> + sep([ Header, indent(Body) ]). + +-spec comma_brackets(string(), string(), [doc()]) -> doc(). +comma_brackets(Open, Close, Ds) -> + beside([text(Open), par(punctuate(text(","), Ds), 0), text(Close)]). + +-spec tuple([doc()]) -> doc(). +tuple(Ds) -> + comma_brackets("(", ")", Ds). + +-spec list([doc()]) -> doc(). +list(Ds) -> + comma_brackets("[", "]", Ds). + +-spec record([doc()]) -> doc(). +record(Ds) -> + comma_brackets("{", "}", Ds). + +%% equals(A, B) -> A = B +-spec equals(doc(), doc()) -> doc(). +equals(A, B) -> follow(hsep(A, text("=")), B). + +%% typed(A, B) -> A : B. +-spec typed(doc(), aeso_syntax:type()) -> doc(). +typed(A, Type) -> + case aeso_syntax:get_ann(origin, Type) == system andalso + not show_generated() of + true -> A; + false -> follow(hsep(A, text(":")), type(Type)) + end. + +%% -- Exports ---------------------------------------------------------------- + +-spec decls([aeso_syntax:decl()], options()) -> doc(). +decls(Ds, Options) -> + with_options(Options, fun() -> decls(Ds) end). + +-spec decls([aeso_syntax:decl()]) -> doc(). +decls(Ds) -> above([ decl(D) || D <- Ds ]). + +-spec decl(aeso_syntax:decl(), options()) -> doc(). +decl(D, Options) -> + with_options(Options, fun() -> decl(D) end). + +-spec decl(aeso_syntax:decl()) -> doc(). +decl({contract, _, C, Ds}) -> + block(follow(text("contract"), hsep(name(C), text("="))), decls(Ds)); +decl({type_decl, _, T, Vars}) -> typedecl(alias_t, T, Vars); +decl({type_def, _, T, Vars, Def}) -> + Kind = element(1, Def), + equals(typedecl(Kind, T, Vars), typedef(Def)); +decl({fun_decl, _, F, T}) -> + hsep(text("function"), typed(name(F), T)); +decl(D = {letfun, Attrs, _, _, _, _}) -> + Mod = fun({Mod, true}) when Mod == private; Mod == internal; Mod == public; Mod == stateful -> + text(atom_to_list(Mod)); + (_) -> empty() end, + hsep(lists:map(Mod, Attrs) ++ [letdecl("function", D)]); +decl(D = {letval, _, _, _, _}) -> letdecl("let", D); +decl(D = {letrec, _, _}) -> letdecl("let", D). + +-spec expr(aeso_syntax:expr(), options()) -> doc(). +expr(E, Options) -> + with_options(Options, fun() -> expr(E) end). + +-spec expr(aeso_syntax:expr()) -> doc(). +expr(E) -> expr_p(0, E). + +%% -- Not exported ----------------------------------------------------------- + +-spec name(aeso_syntax:id() | aeso_syntax:con() | aeso_syntax:tvar()) -> doc(). +name({id, _, Name}) -> text(Name); +name({con, _, Name}) -> text(Name); +name({qid, _, Names}) -> text(string:join(Names, ".")); +name({qcon, _, Names}) -> text(string:join(Names, ".")); +name({tvar, _, Name}) -> text(Name); +name({typed, _, Name, _}) -> name(Name). + +-spec letdecl(string(), aeso_syntax:letbind()) -> doc(). +letdecl(Let, {letval, _, F, T, E}) -> + block_expr(0, hsep([text(Let), typed(name(F), T), text("=")]), E); +letdecl(Let, {letfun, _, F, Args, T, E}) -> + block_expr(0, hsep([text(Let), typed(beside(name(F), args(Args)), T), text("=")]), E); +letdecl(Let, {letrec, _, [D | Ds]}) -> + hsep(text(Let), above([ letdecl("rec", D) | [ letdecl("and", D1) || D1 <- Ds ] ])). + +-spec args([aeso_syntax:arg()]) -> doc(). +args(Args) -> + tuple(lists:map(fun arg/1, Args)). + +-spec arg(aeso_syntax:arg()) -> doc(). +arg({arg, _, X, T}) -> typed(name(X), T). + +-spec typedecl(alias_t | record_t | variant_t, aeso_syntax:id(), [aeso_syntax:tvar()]) -> doc(). +typedecl(Kind, T, Vars) -> + KW = case Kind of + alias_t -> text("type"); + record_t -> text("record"); + variant_t -> text("datatype") + end, + case Vars of + [] -> hsep(KW, name(T)); + _ -> beside(hsep(KW, name(T)), + tuple(lists:map(fun name/1, Vars))) + end. + +-spec typedef(aeso_syntax:typedef()) -> doc(). +typedef({alias_t, Type}) -> type(Type); +typedef({record_t, Fields}) -> + record(lists:map(fun field_t/1, Fields)); +typedef({variant_t, Constructors}) -> + par(punctuate(text(" |"), lists:map(fun constructor_t/1, Constructors))). + +-spec constructor_t(aeso_syntax:constructor_t()) -> doc(). +constructor_t({constr_t, _, C, []}) -> name(C); +constructor_t({constr_t, _, C, Args}) -> beside(name(C), tuple_type(Args)). + +-spec field_t(aeso_syntax:field_t()) -> doc(). +field_t({field_t, _, Name, Type}) -> + typed(name(Name), Type). + +-spec type(aeso_syntax:type(), options()) -> doc(). +type(Type, Options) -> + with_options(Options, fun() -> type(Type) end). + +-spec type(aeso_syntax:type()) -> doc(). +type({fun_t, _, Named, Args, Ret}) -> + follow(hsep(tuple_type(Named ++ Args), text("=>")), type(Ret)); +type({app_t, _, Type, []}) -> + type(Type); +type({app_t, _, Type, Args}) -> + beside(type(Type), tuple_type(Args)); +type({tuple_t, _, Args}) -> + tuple_type(Args); +type({named_arg_t, _, Name, Type, Default}) -> + follow(hsep(typed(name(Name), Type), text("=")), expr(Default)); + +type(R = {record_t, _}) -> typedef(R); +type(T = {id, _, _}) -> name(T); +type(T = {qid, _, _}) -> name(T); +type(T = {con, _, _}) -> name(T); +type(T = {qcon, _, _}) -> name(T); +type(T = {tvar, _, _}) -> name(T). + +-spec tuple_type([aeso_syntax:type()]) -> doc(). +tuple_type(Args) -> + tuple(lists:map(fun type/1, Args)). + +-spec arg_expr(aeso_syntax:arg_expr()) -> doc(). +arg_expr({named_arg, _, Name, E}) -> + follow(hsep(expr(Name), text("=")), expr(E)); +arg_expr(E) -> expr(E). + +-spec expr_p(integer(), aeso_syntax:expr()) -> doc(). +expr_p(P, {lam, _, Args, E}) -> + paren(P > 100, follow(hsep(args(Args), text("=>")), expr_p(100, E))); +expr_p(P, If = {'if', Ann, Cond, Then, Else}) -> + Format = aeso_syntax:get_ann(format, If), + if Format == '?:' -> + paren(P > 100, + follow(expr_p(200, Cond), + follow(hsep(text("?"), expr_p(100, Then)), + hsep(text(":"), expr_p(100, Else)), 0))); + true -> + {Elifs, Else1} = get_elifs(Else), + above([ stmt_p(Stmt) || Stmt <- [{'if', Ann, Cond, Then} | Elifs] ++ [Else1]]) + end; +expr_p(_P, {switch, _, E, Cases}) -> + block(beside(text("switch"), paren(expr(E))), + above(lists:map(fun alt/1, Cases))); +expr_p(_, {tuple, _, Es}) -> + tuple(lists:map(fun expr/1, Es)); +expr_p(_, {list, _, Es}) -> + list(lists:map(fun expr/1, Es)); +expr_p(_, {record, _, Fs}) -> + record(lists:map(fun field/1, Fs)); +expr_p(_, {map, Ann, KVs}) -> + record([ field({field, Ann, [{map_get, [], K}], V}) || {K, V} <- KVs ]); +expr_p(P, {map, Ann, E, Flds}) -> + expr_p(P, {record, Ann, E, Flds}); +expr_p(P, {record, Ann, E, Fs}) -> + paren(P > 900, hsep(expr_p(900, E), expr({record, Ann, Fs}))); +expr_p(_, {block, _, Ss}) -> + block(empty(), statements(Ss)); +expr_p(P, {proj, _, E, X}) -> + paren(P > 900, beside([expr_p(900, E), text("."), name(X)])); +expr_p(P, {map_get, _, E, Key}) -> + paren(P > 900, beside([expr_p(900, E), list([expr(Key)])])); +expr_p(P, {map_get, Ann, E, Key, Val}) -> + paren(P > 900, beside([expr_p(900, E), list([expr(equals(Ann, Key, Val))])])); +expr_p(P, {typed, _, E, T}) -> + paren(P > 0, typed(expr(E), T)); +expr_p(P, {assign, _, LV, E}) -> + paren(P > 0, equals(expr_p(900, LV), expr(E))); +%% -- Operators +expr_p(_, {app, _, {'..', _}, [A, B]}) -> + list([infix(0, '..', A, B)]); +expr_p(P, E = {app, _, F = {Op, _}, Args}) when is_atom(Op) -> + case {aeso_syntax:get_ann(format, E), Args} of + {infix, [A, B]} -> infix(P, Op, A, B); + {prefix, [A]} -> prefix(P, Op, A); + _ -> app(P, F, Args) + end; +expr_p(P, {app, _, F, Args}) -> + app(P, F, Args); +%% -- Constants +expr_p(_, E = {int, _, N}) -> + S = case aeso_syntax:get_ann(format, E) of + hex -> "0x" ++ integer_to_list(N, 16); + _ -> integer_to_list(N) + end, + text(S); +expr_p(_, {bool, _, B}) -> text(atom_to_list(B)); +expr_p(_, {hash, _, <>}) -> text("#" ++ integer_to_list(N, 16)); +expr_p(_, {unit, _}) -> text("()"); +expr_p(_, {string, _, S}) -> term(binary_to_list(S)); +expr_p(_, {char, _, C}) -> + case C of + $' -> text("'\\''"); + $" -> text("'\"'"); + _ -> S = lists:flatten(io_lib:format("~p", [[C]])), + text("'" ++ tl(lists:droplast(S)) ++ "'") + end; +%% -- Names +expr_p(_, E = {id, _, _}) -> name(E); +expr_p(_, E = {con, _, _}) -> name(E); +expr_p(_, E = {qid, _, _}) -> name(E); +expr_p(_, E = {qcon, _, _}) -> name(E); +%% -- For error messages +expr_p(_, {Op, _}) when is_atom(Op) -> + paren(text(atom_to_list(Op))); +expr_p(_, {lvalue, _, LV}) -> lvalue(LV). + +stmt_p({'if', _, Cond, Then}) -> + block_expr(200, beside(text("if"), paren(expr(Cond))), Then); +stmt_p({elif, _, Cond, Then}) -> + block_expr(200, beside(text("elif"), paren(expr(Cond))), Then); +stmt_p({else, Else}) -> + HideGenerated = not show_generated(), + case aeso_syntax:get_ann(origin, Else) of + system when HideGenerated -> empty(); + _ -> block_expr(200, text("else"), Else) + end. + +-spec bin_prec(aeso_syntax:bin_op()) -> {integer(), integer(), integer()}. +bin_prec('..') -> { 0, 0, 0}; %% Always printed inside '[ ]' +bin_prec('=') -> { 0, 0, 0}; %% Always printed inside '[ ]' +bin_prec('||') -> {200, 300, 200}; +bin_prec('&&') -> {300, 400, 300}; +bin_prec('<') -> {400, 500, 500}; +bin_prec('>') -> {400, 500, 500}; +bin_prec('=<') -> {400, 500, 500}; +bin_prec('>=') -> {400, 500, 500}; +bin_prec('==') -> {400, 500, 500}; +bin_prec('!=') -> {400, 500, 500}; +bin_prec('++') -> {500, 600, 500}; +bin_prec('::') -> {500, 600, 500}; +bin_prec('+') -> {600, 600, 650}; +bin_prec('-') -> {600, 600, 650}; +bin_prec('bor') -> {600, 600, 650}; +bin_prec('bxor') -> {600, 600, 650}; +bin_prec('bsl') -> {600, 600, 650}; +bin_prec('bsr') -> {600, 600, 650}; +bin_prec('*') -> {700, 700, 750}; +bin_prec('/') -> {700, 700, 750}; +bin_prec(mod) -> {700, 700, 750}; +bin_prec('band') -> {700, 700, 750}; +bin_prec('^') -> {750, 750, 800}. + +-spec un_prec(aeso_syntax:un_op()) -> {integer(), integer()}. +un_prec('-') -> {650, 650}; +un_prec('!') -> {800, 800}; +un_prec('bnot') -> {800, 800}. + +equals(Ann, A, B) -> + {app, [{format, infix} | Ann], {'=', Ann}, [A, B]}. + +-spec infix(integer(), aeso_syntax:bin_op(), aeso_syntax:expr(), aeso_syntax:expr()) -> doc(). +infix(P, Op, A, B) -> + {Top, L, R} = bin_prec(Op), + paren(P > Top, + follow(hsep(expr_p(L, A), text(atom_to_list(Op))), + expr_p(R, B))). + +prefix(P, Op, A) -> + {Top, Inner} = un_prec(Op), + paren(P > Top, hsep(text(atom_to_list(Op)), expr_p(Inner, A))). + +app(P, F, Args) -> + paren(P > 900, + beside(expr_p(900, F), + tuple(lists:map(fun arg_expr/1, Args)))). + +field({field, _, LV, E}) -> + follow(hsep(lvalue(LV), text("=")), expr(E)); +field({field, _, LV, Id, E}) -> + follow(hsep([lvalue(LV), text("@"), name(Id), text("=")]), expr(E)); +field({field_upd, _, LV, Fun}) -> + follow(hsep(lvalue(LV), text("~")), expr(Fun)). %% Not valid syntax + +lvalue([E | Es]) -> + beside([elim(E) | lists:map(fun elim1/1, Es)]). + +elim({proj, _, X}) -> name(X); +elim({map_get, Ann, K}) -> expr_p(0, {list, Ann, [K]}); +elim({map_get, Ann, K, V}) -> expr_p(0, {list, Ann, [equals(Ann, K, V)]}). + +elim1(Proj={proj, _, _}) -> beside(text("."), elim(Proj)); +elim1(Get={map_get, _, _}) -> elim(Get); +elim1(Get={map_get, _, _, _}) -> elim(Get). + +alt({'case', _, Pat, Body}) -> + block_expr(0, hsep(expr_p(500, Pat), text("=>")), Body). + +block_expr(_, Header, {block, _, Ss}) -> + block(Header, statements(Ss)); +block_expr(P, Header, E) -> + follow(Header, expr_p(P, E)). + +statements(Stmts) -> + above([ statement(S) || S <- Stmts ]). + +statement(S = {letval, _, _, _, _}) -> letdecl("let", S); +statement(S = {letfun, _, _, _, _, _}) -> letdecl("let", S); +statement(S = {letrec, _, _}) -> letdecl("let", S); +statement(E) -> expr(E). + +get_elifs(Expr) -> get_elifs(Expr, []). + +get_elifs(If = {'if', Ann, Cond, Then, Else}, Elifs) -> + case aeso_syntax:get_ann(format, If) of + elif -> get_elifs(Else, [{elif, Ann, Cond, Then} | Elifs]); + _ -> {lists:reverse(Elifs), If} + end; +get_elifs(Else, Elifs) -> {lists:reverse(Elifs), {else, Else}}. + +fmt(Fmt, Args) -> text(lists:flatten(io_lib:format(Fmt, Args))). +term(X) -> fmt("~p", [X]). + diff --git a/src/aeso_scan.erl b/src/aeso_scan.erl new file mode 100644 index 0000000..5cee063 --- /dev/null +++ b/src/aeso_scan.erl @@ -0,0 +1,127 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc The Sophia lexer. +%%% +%%% @end +%%%------------------------------------------------------------------- +-module(aeso_scan). + +-export([scan/1]). + +-import(aeso_scan_lib, [token/1, token/2, symbol/0, skip/0, + override/2, push/2, pop/1]). + +lexer() -> + DIGIT = "[0-9]", + HEXDIGIT = "[0-9a-fA-F]", + LOWER = "[a-z_]", + UPPER = "[A-Z]", + CON = [UPPER, "[a-zA-Z0-9_]*"], + INT = [DIGIT, "+"], + HEX = ["0x", HEXDIGIT, "+"], + HASH = ["#", HEXDIGIT, "+"], + WS = "[\\000-\\ ]+", + ID = [LOWER, "[a-zA-Z0-9_']*"], + TVAR = ["'", ID], + QID = ["(", CON, "\\.)+", ID], + QCON = ["(", CON, "\\.)+", CON], + OP = "[=!<>+\\-*/:&|?~@^]+", + CHAR = "'([^'\\\\]|(\\\\.))'", + STRING = "\"([^\"\\\\]|(\\\\.))*\"", + + CommentStart = {"/\\*", push(comment, skip())}, + CommentRules = + [ CommentStart + , {"\\*/", pop(skip())} + , {"[^/*]+|[/*]", skip()} ], + + Keywords = ["contract", "import", "let", "rec", "switch", "type", "record", "datatype", "if", "elif", "else", "function", + "stateful", "true", "false", "and", "mod", "public", "private", "indexed", "internal", + "band", "bor", "bxor", "bsl", "bsr", "bnot"], + KW = string:join(Keywords, "|"), + + Rules = + %% Comments and whitespace + [ CommentStart + , {"//.*", skip()} + , {WS, skip()} + + %% Special characters + , {"\\.\\.|[,.;()\\[\\]{}]", symbol()} + + %% Literals + , {CHAR, token(char, fun parse_char/1)} + , {STRING, token(string, fun parse_string/1)} + , {HEX, token(hex, fun parse_hex/1)} + , {INT, token(int, fun list_to_integer/1)} + , {HASH, token(hash, fun parse_hash/1)} + + %% Identifiers (qualified first!) + , {QID, token(qid, fun(S) -> string:tokens(S, ".") end)} + , {QCON, token(qcon, fun(S) -> string:tokens(S, ".") end)} + , {TVAR, token(tvar)} + , override({ID, token(id)}, {KW, symbol()}) %% Keywords override identifiers. Need to + , {CON, token(con)} %% use override to avoid lexing "lettuce" + %% as ['let', {id, "tuce"}]. + %% Operators + , {OP, symbol()} + ], + + [{code, Rules}, {comment, CommentRules}]. + +scan(String) -> + Lexer = aeso_scan_lib:compile(lexer()), + aeso_scan_lib:string(Lexer, code, String). + +%% -- Helpers ---------------------------------------------------------------- + +parse_string([$" | Chars]) -> + unescape(Chars). + +parse_char([$', $\\, Code, $']) -> + case Code of + $' -> $'; + $\\ -> $\\; + $b -> $\b; + $e -> $\e; + $f -> $\f; + $n -> $\n; + $r -> $\r; + $t -> $\t; + $v -> $\v; + _ -> {error, "Bad control sequence: \\" ++ [Code]} + end; +parse_char([$', C, $']) -> C. + +unescape(Str) -> unescape(Str, []). + +%% TODO: numeric escapes +unescape([$"], Acc) -> + list_to_binary(lists:reverse(Acc)); +unescape([$\\, Code | Chars], Acc) -> + Ok = fun(C) -> unescape(Chars, [C | Acc]) end, + case Code of + $" -> Ok($"); + $\\ -> Ok($\\); + $b -> Ok($\b); + $e -> Ok($\e); + $f -> Ok($\f); + $n -> Ok($\n); + $r -> Ok($\r); + $t -> Ok($\t); + $v -> Ok($\v); + _ -> error("Bad control sequence: \\" ++ [Code]) %% TODO + end; +unescape([C | Chars], Acc) -> + unescape(Chars, [C | Acc]). + +parse_hex("0x" ++ Chars) -> list_to_integer(Chars, 16). + +parse_hash("#" ++ Chars) -> + N = list_to_integer(Chars, 16), + case length(Chars) > 64 of %% 64 hex digits = 32 bytes + true -> <>; %% signature + false -> <> %% address + end. + diff --git a/src/aeso_scan_lib.erl b/src/aeso_scan_lib.erl new file mode 100644 index 0000000..66b4ecb --- /dev/null +++ b/src/aeso_scan_lib.erl @@ -0,0 +1,147 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc A customisable lexer. +%%% @end +%%%------------------------------------------------------------------- +-module(aeso_scan_lib). + +-export([compile/1, string/3, + token/1, token/2, symbol/0, skip/0, + override/2, push/2, pop/1]). + +-export_type([lexer/0, token_spec/0, token_action/0, token/0, pos/0, regex/0]). + +%% -- Exported types -- + +-type regex() :: iodata() | unicode:charlist(). +-type pos() :: {integer(), integer()}. +-type lex_state() :: atom(). +-type token() :: {atom(), pos(), term()} | {atom(), pos()}. + +-type token_spec() :: {regex(), token_action()}. +-opaque token_action() :: fun((string(), pos()) -> {tok_result(), state_change()}). + +-opaque lexer() :: [{lex_state(), + fun((string(), pos()) -> {ok, tok_result(), string(), pos()} + | end_of_file | error)}]. + +%% -- Internal types -- +-type tok_result() :: {token, token()} | skip. +-type state_change() :: none | pop | {push, lex_state()}. + +%% @doc Compile a lexer specification. Takes the regexps for each state and +%% combines them into a single big regexp that is then compiled with re:compile/1. +%% Note: contrary to lexer generators like leex, we don't have longest match +%% semantics (since this isn't supported by re). Use override/2 instead. +-spec compile([{lex_state(), [token_spec()]}]) -> lexer(). +compile(TokenSpecs) -> + [{S, compile_spec(Spec)} || {S, Spec} <- TokenSpecs]. + +compile_spec(TokenSpecs) -> + WithIxs = lists:zip(lists:seq(1, length(TokenSpecs)), TokenSpecs), + {ok, Regex} = re:compile(["^(", name(0), string:join([ ["(", name(I), R, ")"] || {I, {R, _}} <- WithIxs ], "|"),")"]), + Actions = [ Fun || {_, Fun} <- TokenSpecs ], + fun ("", _Pos) -> end_of_file; + (S, Pos) -> + case re:run(S, Regex, [{capture, all_names}]) of + {match, [{0, N} | Capture]} -> + Index = 1 + length(lists:takewhile(fun({P, _}) -> P == -1 end, Capture)), + Action = lists:nth(Index, Actions), + {TokS, Rest} = lists:split(N, S), + Tok = Action(TokS, Pos), + {ok, Tok, Rest, next_pos(TokS, Pos)}; + nomatch -> + error + end + end. + +%% @doc Produce a token with the given tag and the matched string as the +%% value. +-spec token(atom()) -> token_action(). +token(Tag) -> + token(Tag, fun(X) -> X end). + +%% @doc Produce a token with the given tag and the value computed from the +%% matched string using the function. +-spec token(atom(), fun((string()) -> term())) -> token_action(). +token(Tag, Fun) -> + fun(S, P) -> {{token, {Tag, P, Fun(S)}}, none} end. + +%% @doc Produce a token with the matched string (converted to an atom) as the +%% tag and no value. +-spec symbol() -> token_action(). +symbol() -> + fun(S, P) -> {{token, {list_to_atom(S), P}}, none} end. + +%% @doc Skip the matched string, producing no token. +-spec skip() -> token_action(). +skip() -> + fun(_, _) -> {skip, none} end. + +%% @doc Enter the given state and perform the given action. The argument action +%% should not change the state. +-spec push(lex_state(), token_action()) -> token_action(). +push(State, Action) -> + fun(S, P) -> {Res, _} = Action(S, P), {Res, {push, State}} end. + +%% @doc Exit from the current state and perform the given action. The argument +%% action should not change the state. +-spec pop(token_action()) -> token_action(). +pop(Action) -> + fun(S, P) -> {Res, _} = Action(S, P), {Res, pop} end. + +%% @doc Match using the first spec, but if the second spec also matches use +%% that one instead. Use this for overlapping tokens (like identifiers and +%% keywords), since matching does not have longest-match semantics. +-spec override(token_spec(), token_spec()) -> token_spec(). +override({Re1, Action1}, {Re2, Action2}) -> + {ok, Compiled} = re:compile(["^(", Re2, ")$"]), + {Re1, fun(S, P) -> + case re:run(S, Compiled, [{capture, none}]) of + match -> Action2(S, P); + nomatch -> Action1(S, P) + end end}. + +%% @doc Run a lexer. Takes the starting state and the string to lex. +-spec string(lexer(), lex_state(), string()) -> {ok, [token()]} | {error, term()}. +string(Lexer, State, String) -> string(Lexer, [State], String, {1, 1}). + +string(Lexer, Stack, String, Pos) -> + Lines = string:split(String, "\n", all), + string(Lexer, Stack, Lines, Pos, []). + +string(_Lexers, [], [Line | _Rest], Pos, _Acc) -> + {error, {{Line,Pos}, scan_error_no_state}}; +string(_Lexers, _Stack, [], _Pos, Acc) -> + {ok, lists:reverse(Acc)}; +string(Lexers, [State | Stack], [Line | Lines], Pos, Acc) -> + Lexer = proplists:get_value(State, Lexers, State), + case Lexer(Line, Pos) of + {ok, {Res, StateChange}, Line1, Pos1} -> + Acc1 = case Res of + {token, Tok} -> [Tok | Acc]; + skip -> Acc + end, + Stack1 = case StateChange of + none -> [State | Stack]; + pop -> Stack; + {push, State1} -> [State1, State | Stack] + end, + string(Lexers, Stack1, [Line1 | Lines], Pos1, Acc1); + end_of_file -> string(Lexers, [State | Stack], Lines, next_pos("\n", Pos), Acc); + error -> {error, {{Line,Pos}, scan_error}} + end. + +%% -- Internal functions ----------------------------------------------------- + +name(I) -> + io_lib:format("?", [I]). + +-define(TAB_SIZE, 8). + +next_pos([], P) -> P; +next_pos([$\n | S], {L, _}) -> next_pos(S, {L + 1, 1}); +next_pos([$\t | S], {L, C}) -> next_pos(S, {L, (C + ?TAB_SIZE - 1) div ?TAB_SIZE * ?TAB_SIZE + 1}); +next_pos([_ | S], {L, C}) -> next_pos(S, {L, C + 1}). + diff --git a/src/aeso_sophia.erl b/src/aeso_sophia.erl new file mode 100644 index 0000000..96d6700 --- /dev/null +++ b/src/aeso_sophia.erl @@ -0,0 +1,30 @@ +-module(aeso_sophia). + +-export_type([data/0, + type/0, + heap/0]). + +-type type() :: word | signed_word | string | typerep | function + | {list, type()} + | {option, type()} + | {tuple, [type()]} + | {variant, [[type()]]}. + + +-type data() :: none + | {some, data()} + | {option, data()} + | word + | string + | {list, data()} + | {tuple, [data()]} + | {variant, integer(), [data()]} + | integer() + | binary() + | [data()] + | {} + | {data()} + | {data(), data()}. + +-type heap() :: binary(). + diff --git a/src/aeso_syntax.erl b/src/aeso_syntax.erl new file mode 100644 index 0000000..5767e82 --- /dev/null +++ b/src/aeso_syntax.erl @@ -0,0 +1,142 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc Sophia abstract syntax types. +%%% +%%% @end +%%%------------------------------------------------------------------- + +-module(aeso_syntax). + +-export([get_ann/1, get_ann/2, get_ann/3, set_ann/2]). + +-export_type([ann_line/0, ann_col/0, ann_origin/0, ann_format/0, ann/0]). +-export_type([name/0, id/0, con/0, qid/0, qcon/0, tvar/0, op/0]). +-export_type([bin_op/0, un_op/0]). +-export_type([decl/0, letbind/0, typedef/0]). +-export_type([arg/0, field_t/0, constructor_t/0]). +-export_type([type/0, constant/0, expr/0, arg_expr/0, field/1, stmt/0, alt/0, lvalue/0, pat/0]). +-export_type([ast/0]). + +-type ast() :: [decl()]. + +-type ann_line() :: integer(). +-type ann_col() :: integer(). +-type ann_origin() :: system | user. +-type ann_format() :: '?:' | hex | infix | prefix | elif. + +-type ann() :: [{line, ann_line()} | {col, ann_col()} | {format, ann_format()} | {origin, ann_origin()}]. + +-type name() :: string(). +-type id() :: {id, ann(), name()}. +-type con() :: {con, ann(), name()}. +-type qid() :: {qid, ann(), [name()]}. +-type qcon() :: {qcon, ann(), [name()]}. +-type tvar() :: {tvar, ann(), name()}. + +-type decl() :: {contract, ann(), con(), [decl()]} + | {type_decl, ann(), id(), [tvar()]} + | {type_def, ann(), id(), [tvar()], typedef()} + | {fun_decl, ann(), id(), type()} + | letbind(). + +-type letbind() + :: {letval, ann(), id(), type(), expr()} + | {letfun, ann(), id(), [arg()], type(), expr()} + | {letrec, ann(), [letbind()]}. + +-type arg() :: {arg, ann(), id(), type()}. + +-type typedef() + :: {alias_t, type()} + | {record_t, [field_t()]} + | {variant_t, [constructor_t()]}. + +-type field_t() :: {field_t, ann(), id(), type()}. + +-type constructor_t() :: {constr_t, ann(), con(), [type()]}. + +-type type() :: {fun_t, ann(), [named_arg_t()], [type()], type()} + | {app_t, ann(), type(), [type()]} + | {tuple_t, ann(), [type()]} + | id() | qid() + | con() | qcon() %% contracts + | tvar(). + +-type named_arg_t() :: {named_arg_t, ann(), id(), type(), expr()}. + +-type constant() + :: {int, ann(), integer()} + | {bool, ann(), true | false} + | {hash, ann(), binary()} + | {unit, ann()} + | {string, ann(), binary()} + | {char, ann(), integer()}. + +-type op() :: bin_op() | un_op(). + +-type bin_op() :: '+' | '-' | '*' | '/' | mod | '^' | 'band' | 'bor' | 'bsl' | 'bsr' | 'bxor' + | '++' | '::' | '<' | '>' | '=<' | '>=' | '==' | '!=' + | '||' | '&&' | '..'. +-type un_op() :: '-' | '!' | 'bnot'. + +-type expr() + :: {lam, ann(), [arg()], expr()} + | {'if', ann(), expr(), expr(), expr()} + | {switch, ann(), expr(), [alt()]} + | {app, ann(), expr(), [arg_expr()]} + | {proj, ann(), expr(), id()} + | {tuple, ann(), [expr()]} + | {list, ann(), [expr()]} + | {typed, ann(), expr(), type()} + | {record, ann(), [field(expr())]} + | {record, ann(), expr(), [field(expr())]} %% record update + | {map, ann(), expr(), [field(expr())]} %% map update + | {map, ann(), [{expr(), expr()}]} + | {map_get, ann(), expr(), expr()} + | {map_get, ann(), expr(), expr(), expr()} + | {block, ann(), [stmt()]} + | {op(), ann()} + | id() | qid() | con() | qcon() + | constant(). + +-type arg_expr() :: expr() | {named_arg, ann(), id(), expr()}. + +%% When lvalue is a projection this is sugar for accessing fields in nested +%% records. For instance, +%% r { x.y: 5 } +%% is the same as +%% r { x: r.x { y: 5 } } +-type field(E) :: {field, ann(), lvalue(), E} + | {field, ann(), lvalue(), id(), E}. %% modifying a field (id is previous value) + +-type stmt() :: letbind() + | expr(). + +-type alt() :: {'case', ann(), pat(), expr()}. + +-type lvalue() :: nonempty_list(elim()). + +-type elim() :: {proj, ann(), id()} + | {map_get, ann(), expr()} + | {map_get, ann(), expr(), expr()}. + +-type pat() :: {app, ann(), con() | op(), [pat()]} + | {tuple, ann(), [pat()]} + | {list, ann(), [pat()]} + | {record, ann(), [field(pat())]} + | constant() + | con() + | id(). + +get_ann(Node) when is_tuple(Node) -> element(2, Node); +get_ann(Ann) when is_list(Ann) -> Ann. + +set_ann(Ann1, Node) when is_tuple(Node) -> setelement(2, Node, Ann1); +set_ann(Ann1, Ann) when is_list(Ann) -> Ann1. + +get_ann(Key, Node) -> + proplists:get_value(Key, get_ann(Node)). + +get_ann(Key, Node, Default) -> + proplists:get_value(Key, get_ann(Node), Default). diff --git a/src/aeso_syntax_utils.erl b/src/aeso_syntax_utils.erl new file mode 100644 index 0000000..e94db73 --- /dev/null +++ b/src/aeso_syntax_utils.erl @@ -0,0 +1,94 @@ +%%%------------------------------------------------------------------- +%%% @copyright (C) 2018, Aeternity Anstalt +%%% @doc +%%% Sophia syntax utilities. +%%% @end +%%%------------------------------------------------------------------- +-module(aeso_syntax_utils). + +-export([used_ids/1, used_types/1]). + +%% Var set combinators +none() -> []. +one(X) -> [X]. +union_map(F, Xs) -> lists:umerge(lists:map(F, Xs)). +minus(Xs, Ys) -> Xs -- Ys. + +%% Compute names used by a definition or expression. +used_ids(Es) when is_list(Es) -> + union_map(fun used_ids/1, Es); +used_ids({bind, A, B}) -> + minus(used_ids(B), used_ids(A)); +%% Declarations +used_ids({contract, _, _, Decls}) -> used_ids(Decls); +used_ids({type_decl, _, _, _}) -> none(); +used_ids({type_def, _, _, _, _}) -> none(); +used_ids({fun_decl, _, _, _}) -> none(); +used_ids({letval, _, _, _, E}) -> used_ids(E); +used_ids({letfun, _, _, Args, _, E}) -> used_ids({bind, Args, E}); +used_ids({letrec, _, Decls}) -> used_ids(Decls); +%% Args +used_ids({arg, _, X, _}) -> used_ids(X); +used_ids({named_arg, _, _, E}) -> used_ids(E); +%% Constants +used_ids({int, _, _}) -> none(); +used_ids({bool, _, _}) -> none(); +used_ids({hash, _, _}) -> none(); +used_ids({unit, _}) -> none(); +used_ids({string, _, _}) -> none(); +used_ids({char, _, _}) -> none(); +%% Expressions +used_ids({lam, _, Args, E}) -> used_ids({bind, Args, E}); +used_ids({'if', _, A, B, C}) -> used_ids([A, B, C]); +used_ids({switch, _, E, Bs}) -> used_ids([E, Bs]); +used_ids({app, _, E, Es}) -> used_ids([E | Es]); +used_ids({proj, _, E, _}) -> used_ids(E); +used_ids({tuple, _, Es}) -> used_ids(Es); +used_ids({list, _, Es}) -> used_ids(Es); +used_ids({typed, _, E, _}) -> used_ids(E); +used_ids({record, _, Fs}) -> used_ids(Fs); +used_ids({record, _, E, Fs}) -> used_ids([E, Fs]); +used_ids({map, _, E, Fs}) -> used_ids([E, Fs]); +used_ids({map, _, KVs}) -> used_ids([ [K, V] || {K, V} <- KVs ]); +used_ids({map_get, _, M, K}) -> used_ids([M, K]); +used_ids({map_get, _, M, K, V}) -> used_ids([M, K, V]); +used_ids({block, _, Ss}) -> used_ids_s(Ss); +used_ids({Op, _}) when is_atom(Op) -> none(); +used_ids({id, _, X}) -> [X]; +used_ids({qid, _, _}) -> none(); +used_ids({con, _, _}) -> none(); +used_ids({qcon, _, _}) -> none(); +%% Switch branches +used_ids({'case', _, P, E}) -> used_ids({bind, P, E}); +%% Fields +used_ids({field, _, LV, E}) -> used_ids([LV, E]); +used_ids({field, _, LV, X, E}) -> used_ids([LV, {bind, X, E}]); +used_ids({proj, _, _}) -> none(); +used_ids({map_get, _, E}) -> used_ids(E). + +%% Statements +used_ids_s([]) -> none(); +used_ids_s([S | Ss]) -> + used_ids([S, {bind, bound_ids(S), {block, [], Ss}}]). + +bound_ids({letval, _, X, _, _}) -> one(X); +bound_ids({letfun, _, X, _, _, _}) -> one(X); +bound_ids({letrec, _, Decls}) -> union_map(fun bound_ids/1, Decls); +bound_ids(_) -> none(). + +used_types(Ts) when is_list(Ts) -> union_map(fun used_types/1, Ts); +used_types({type_def, _, _, _, T}) -> used_types(T); +used_types({alias_t, T}) -> used_types(T); +used_types({record_t, Fs}) -> used_types(Fs); +used_types({variant_t, Cs}) -> used_types(Cs); +used_types({field_t, _, _, T}) -> used_types(T); +used_types({constr_t, _, _, Ts}) -> used_types(Ts); +used_types({fun_t, _, Named, Args, T}) -> used_types([T | Named ++ Args]); +used_types({named_arg_t, _, _, T, _}) -> used_types(T); +used_types({app_t, _, T, Ts}) -> used_types([T | Ts]); +used_types({tuple_t, _, Ts}) -> used_types(Ts); +used_types({id, _, X}) -> one(X); +used_types({qid, _, _}) -> none(); +used_types({con, _, _}) -> none(); +used_types({qcon, _, _}) -> none(); +used_types({tvar, _, _}) -> none(). diff --git a/src/aeso_utils.erl b/src/aeso_utils.erl new file mode 100644 index 0000000..e86f9ca --- /dev/null +++ b/src/aeso_utils.erl @@ -0,0 +1,68 @@ +%%%------------------------------------------------------------------- +%%% @copyright (C) 2018, Aeternity Anstalt +%%% @doc +%%% Sophia utility functions. +%%% @end +%%%------------------------------------------------------------------- +-module(aeso_utils). + +-export([scc/1]). + +-export_type([graph/1]). + +%% -- Topological sort + +-type graph(Node) :: #{Node => [Node]}. %% List of incoming edges (dependencies). + +%% Topologically sorted strongly-connected components of a graph. +-spec scc(graph(Node)) -> [{cyclic, [Node]} | {acyclic, Node}]. +scc(Graph) -> + Trees = dfs(Graph, lists:reverse(postorder(dff(reverse_graph(Graph))))), + Decode = fun(T) -> + case postorder(T) of + [I] -> case lists:member(I, maps:get(I, Graph, [])) of + true -> {cyclic, [I]}; + false -> {acyclic, I} + end; + Is -> {cyclic, Is} + end end, + lists:map(Decode, Trees). + +%% Depth first spanning forest of a graph. +dff(Graph) -> + dfs(Graph, maps:keys(Graph)). + +dfs(Graph, Vs) -> + {_, Trees} = dfs(Graph, #{}, Vs, []), + Trees. + +dfs(_Graph, Visited, [], Trees) -> {Visited, lists:reverse(Trees)}; +dfs(Graph, Visited, [V | Vs], Trees) -> + case maps:is_key(V, Visited) of + true -> dfs(Graph, Visited, Vs, Trees); + false -> + {Visited1, Tree} = dfs1(Graph, Visited#{ V => true }, V), + dfs(Graph, Visited1, Vs, [Tree | Trees]) + end. + +dfs1(Graph, Visited, V) -> + Ws = maps:get(V, Graph, []), + {Visited1, Trees} = dfs(Graph, Visited, Ws, []), + {Visited1, {V, Trees}}. + +%% Post-order traversal of a tree/forest. +postorder(Tree = {_, _}) -> postorder([Tree]); +postorder(Trees) when is_list(Trees) -> postorder(Trees, []). + +postorder([], Acc) -> Acc; +postorder([{V, Trees1} | Trees], Acc) -> + postorder(Trees1, [V | postorder(Trees, Acc)]). + +from_edges(Is, Es) -> + lists:foldl(fun({I, J}, G) -> + maps:update_with(I, fun(Js) -> lists:umerge([J], Js) end, [J], G) + end, maps:from_list([ {I, []} || I <- Is ]), Es). + +reverse_graph(G) -> + from_edges(maps:keys(G), [ {J, I} || {I, Js} <- maps:to_list(G), J <- Js ]). + diff --git a/src/aesophia.app.src b/src/aesophia.app.src new file mode 100644 index 0000000..1e43dc3 --- /dev/null +++ b/src/aesophia.app.src @@ -0,0 +1,18 @@ +{application, aesophia, + [{description, "Contract Language for Aethernity"}, + {vsn, "0.0.1"}, + {registered, []}, + {applications, + [kernel, + stdlib, + lager, + aebytecode + ]}, + {env,[]}, + {modules, []}, + + {maintainers, []}, + {licenses, []}, + {links, []} + ]}. + diff --git a/test/aeso_abi_tests.erl b/test/aeso_abi_tests.erl new file mode 100644 index 0000000..382c3d6 --- /dev/null +++ b/test/aeso_abi_tests.erl @@ -0,0 +1,88 @@ +-module(aeso_abi_tests). + +-include_lib("eunit/include/eunit.hrl"). +-compile(export_all). + +-define(SANDBOX(Code), sandbox(fun() -> Code end)). + +sandbox(Code) -> + Parent = self(), + Tag = make_ref(), + {Pid, Ref} = spawn_monitor(fun() -> Parent ! {Tag, Code()} end), + receive + {Tag, Res} -> erlang:demonitor(Ref, [flush]), {ok, Res}; + {'DOWN', Ref, process, Pid, Reason} -> {error, Reason} + after 100 -> + exit(Pid, kill), + {error, loop} + end. + +malicious_from_binary_test() -> + CircularList = from_words([32, 1, 32]), %% Xs = 1 :: Xs + {ok, {error, circular_references}} = ?SANDBOX(aeso_heap:from_binary({list, word}, CircularList)), + {ok, {error, {binary_too_short, _}}} = ?SANDBOX(aeso_heap:from_binary(word, <<1, 2, 3, 4>>)), + ok. + +from_words(Ws) -> + << <<(from_word(W))/binary>> || W <- Ws >>. + +from_word(W) when is_integer(W) -> + <>; +from_word(S) when is_list(S) -> + Len = length(S), + Bin = <<(list_to_binary(S))/binary, 0:(32 - Len)/unit:8>>, + <>. + +encode_decode_test() -> + encode_decode(word, 42), + 42 = encode_decode(word, 42), + -1 = encode_decode(signed_word, -1), + <<"Hello world">> = encode_decode(string, <<"Hello world">>), + {} = encode_decode({tuple, []}, {}), + {42} = encode_decode({tuple, [word]}, {42}), + {42, 0} = encode_decode({tuple, [word, word]}, {42, 0}), + [] = encode_decode({list, word}, []), + [32] = encode_decode({list, word}, [32]), + none = encode_decode({option, word}, none), + {some, 1} = encode_decode({option, word}, {some, 1}), + string = encode_decode(typerep, string), + word = encode_decode(typerep, word), + {list, word} = encode_decode(typerep, {list, word}), + {tuple, [word]} = encode_decode(typerep, {tuple, [word]}), + 1 = encode_decode(word, 1), + 0 = encode_decode(word, 0), + ok. + +encode_decode_sophia_test() -> + {42} = encode_decode_sophia_string("int", "42"), + {1} = encode_decode_sophia_string("bool", "true"), + {0} = encode_decode_sophia_string("bool", "false"), + {<<"Hello">>} = encode_decode_sophia_string("string", "\"Hello\""), + {<<"Hello">>, [1,2,3], {variant, 1, [1]}} = + encode_decode_sophia_string( + "(string, list(int), option(bool))", + "\"Hello\", [1,2,3], Some(true)"), + ok. + +encode_decode_sophia_string(SophiaType, String) -> + io:format("String ~p~n", [String]), + Code = [ "contract Call =\n" + , " function foo : ", SophiaType, " => _\n" + , " function __call() = foo(", String, ")\n" ], + {ok, _, {Types, _}, Args} = aeso_compiler:check_call(lists:flatten(Code), []), + Arg = list_to_tuple(Args), + Type = {tuple, Types}, + io:format("Type ~p~n", [Type]), + Data = encode(Arg), + decode(Type, Data). + +encode_decode(T, D) -> + ?assertEqual(D, decode(T, encode(D))), + D. + +encode(D) -> + aeso_heap:to_binary(D). + +decode(T,B) -> + {ok, D} = aeso_heap:from_binary(T, B), + D. diff --git a/test/aeso_compiler_tests.erl b/test/aeso_compiler_tests.erl new file mode 100644 index 0000000..a9e750d --- /dev/null +++ b/test/aeso_compiler_tests.erl @@ -0,0 +1,136 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2018, Aeternity Anstalt +%%% @doc Test Sophia language compiler. +%%% +%%% @end +%%%------------------------------------------------------------------- + +-module(aeso_compiler_tests). + +-include_lib("eunit/include/eunit.hrl"). + +%% simple_compile_test_() -> ok. +%% Very simply test compile the given contracts. Only basic checks +%% are made on the output, just that it is a binary which indicates +%% that the compilation worked. + +simple_compile_test_() -> + {setup, + fun () -> ok end, %Setup + fun (_) -> ok end, %Cleanup + [ {"Testing the " ++ ContractName ++ " contract", + fun() -> + #{byte_code := ByteCode, + contract_source := _, + type_info := _} = compile(ContractName), + ?assertMatch(Code when is_binary(Code), ByteCode) + end} || ContractName <- compilable_contracts() ] ++ + [ {"Testing error messages of " ++ ContractName, + fun() -> + {type_errors, Errors} = compile(ContractName), + ?assertEqual(lists:sort(ExpectedErrors), lists:sort(Errors)) + end} || + {ContractName, ExpectedErrors} <- failing_contracts() ] + }. + +compile(Name) -> + try + aeso_compiler:from_string(aeso_test_utils:read_contract(Name), []) + catch _:{type_errors, _} = E -> + E + end. + +%% compilable_contracts() -> [ContractName]. +%% The currently compilable contracts. + +compilable_contracts() -> + ["complex_types", + "counter", + "dutch_auction", + "environment", + "factorial", + "fundme", + "identity", + "maps", + "oracles", + "remote_call", + "simple", + "simple_storage", + "spend_test", + "stack", + "test", + "builtin_bug", + "builtin_map_get_bug" + ]. + +%% Contracts that should produce type errors + +failing_contracts() -> + [ {"name_clash", + ["Duplicate definitions of abort at\n - (builtin location)\n - line 14, column 3\n", + "Duplicate definitions of double_def at\n - line 10, column 3\n - line 11, column 3\n", + "Duplicate definitions of double_proto at\n - line 4, column 3\n - line 5, column 3\n", + "Duplicate definitions of proto_and_def at\n - line 7, column 3\n - line 8, column 3\n", + "Duplicate definitions of put at\n - (builtin location)\n - line 15, column 3\n", + "Duplicate definitions of state at\n - (builtin location)\n - line 16, column 3\n"]} + , {"type_errors", + ["Unbound variable zz at line 17, column 21\n", + "Cannot unify int\n" + " and list(int)\n" + "when checking the application at line 26, column 9 of\n" + " (::) : (int, list(int)) => list(int)\n" + "to arguments\n" + " x : int\n" + " x : int\n", + "Cannot unify string\n" + " and int\n" + "when checking the assignment of the field\n" + " x : map(string, string) (at line 9, column 46)\n" + "to the old value __x and the new value\n" + " __x {[\"foo\"] @ x = x + 1} : map(string, int)\n", + "Cannot unify int\n" + " and string\n" + "when checking the type of the expression at line 34, column 45\n" + " 1 : int\n" + "against the expected type\n" + " string\n", + "Cannot unify string\n" + " and int\n" + "when checking the type of the expression at line 34, column 50\n" + " \"bla\" : string\n" + "against the expected type\n" + " int\n", + "Cannot unify string\n" + " and int\n" + "when checking the type of the expression at line 32, column 18\n" + " \"x\" : string\n" + "against the expected type\n" + " int\n", + "Cannot unify string\n" + " and int\n" + "when checking the type of the expression at line 11, column 56\n" + " \"foo\" : string\n" + "against the expected type\n" + " int\n", + "Cannot unify int\n" + " and string\n" + "when comparing the types of the if-branches\n" + " - w : int (at line 38, column 13)\n" + " - z : string (at line 39, column 10)\n", + "Not a record type: string\n" + "arising from the projection of the field y (at line 22, column 38)\n", + "Not a record type: string\n" + "arising from an assignment of the field y (at line 21, column 42)\n", + "Not a record type: string\n" + "arising from an assignment of the field y (at line 20, column 38)\n", + "Not a record type: string\n" + "arising from an assignment of the field y (at line 19, column 35)\n", + "Ambiguous record type with field y (at line 13, column 25) could be one of\n" + " - r (at line 4, column 10)\n" + " - r' (at line 5, column 10)\n", + "Record type r2 does not have field y (at line 15, column 22)\n", + "Repeated name x in pattern\n" + " x :: x (at line 26, column 7)\n", + "No record type with fields y, z (at line 14, column 22)\n"]} + ]. diff --git a/test/aeso_eunit_SUITE.erl b/test/aeso_eunit_SUITE.erl new file mode 100644 index 0000000..ed19643 --- /dev/null +++ b/test/aeso_eunit_SUITE.erl @@ -0,0 +1,20 @@ +-module(aeso_eunit_SUITE). + +-compile([export_all, nowarn_export_all]). + +-include_lib("common_test/include/ct.hrl"). + +all() -> + [{group, eunit}]. + +groups() -> + [{eunit, [], [ aeso_scan_tests + , aeso_parser_tests + , aeso_compiler_tests + , aeso_abi_tests + ]}]. + +aeso_scan_tests(_Config) -> ok = eunit:test(aeso_scan_tests). +aeso_parser_tests(_Config) -> ok = eunit:test(aeso_parser_tests). +aeso_compiler_tests(_Config) -> ok = eunit:test(aeso_compiler_tests). +aeso_abi_tests(_Config) -> ok = eunit:test(aeso_abi_tests). diff --git a/test/aeso_parser_tests.erl b/test/aeso_parser_tests.erl new file mode 100644 index 0000000..bebdd91 --- /dev/null +++ b/test/aeso_parser_tests.erl @@ -0,0 +1,111 @@ +-module(aeso_parser_tests). + +-export([parse_contract/1]). + +-include_lib("eunit/include/eunit.hrl"). + +simple_contracts_test_() -> + {foreach, + fun() -> ok end, + fun(_) -> ok end, + [{"Parse a contract with an identity function.", + fun() -> + Text = "contract Identity =\n" + " function id(x) = x\n", + ?assertMatch( + [{contract, _, {con, _, "Identity"}, + [{letfun, _, {id, _, "id"}, [{arg, _, {id, _, "x"}, {id, _, "_"}}], {id, _, "_"}, + {id, _, "x"}}]}], parse_string(Text)), + ok + end}, + {"Operator precedence test.", + fun() -> + NoPar = fun NoPar(X) when is_atom(X) -> atom_to_list(X); + NoPar({A, Op, B}) -> lists:concat([NoPar(A), " ", Op, " ", NoPar(B)]); + NoPar({Op, A}) -> lists:concat([Op, " ", NoPar(A)]) + end, + Par = fun Par(X) when is_atom(X) -> atom_to_list(X); + Par({A, Op, B}) -> lists:concat(["(", Par(A), " ", Op, " ", Par(B), ")"]); + Par({Op, A}) -> lists:concat(["(", Op, " ", Par(A), ")"]) + end, + Parse = fun(S) -> + try remove_line_numbers(parse_expr(S)) + catch _:_ -> ?assertMatch(ok, {parse_fail, S}) end + end, + CheckParens = fun(Expr) -> + ?assertEqual(Parse(NoPar(Expr)), Parse(Par(Expr))) + end, + LeftAssoc = fun(Op) -> CheckParens({{a, Op, b}, Op, c}) end, + RightAssoc = fun(Op) -> CheckParens({a, Op, {b, Op, c}}) end, + NonAssoc = fun(Op) -> + OpAtom = list_to_atom(Op), + ?assertError({error, {_, parse_error, _}}, + parse_expr(NoPar({a, Op, {b, Op, c}}))) end, + Stronger = fun(Op1, Op2) -> + CheckParens({{a, Op1, b}, Op2, c}), + CheckParens({a, Op2, {b, Op1, c}}) + end, + + Tiers = [["||"], ["&&"], ["==", "!=", "<", ">", "=<", ">="], ["::", "++"], + ["+", "-"], ["*", "/", "mod"]], + + %% associativity + [ RightAssoc(Op) || Op <- ["||", "&&", "::", "++"] ], + [ NonAssoc(Op) || Op <- ["==", "!=", "<", ">", "=<", ">="] ], + [ LeftAssoc(Op) || Op <- ["+", "-", "*", "/", "mod"] ], + + %% precedence + [ Stronger(Op2, Op1) || [T1 , T2 | _] <- tails(Tiers), Op1 <- T1, Op2 <- T2 ], + ok + end} + ] ++ + %% Parse tests of example contracts + [ {lists:concat(["Parse the ", Contract, " contract."]), + fun() -> roundtrip_contract(Contract) end} + || Contract <- [counter, voting, all_syntax, '05_greeter', aeproof, multi_sig, simple_storage, withdrawal, fundme, dutch_auction] ] + }. + +parse_contract(Name) -> + parse_string(aeso_test_utils:read_contract(Name)). + +roundtrip_contract(Name) -> + round_trip(aeso_test_utils:read_contract(Name)). + +parse_string(Text) -> + case aeso_parser:string(Text) of + {ok, Contract} -> Contract; + Err -> error(Err) + end. + +parse_expr(Text) -> + [{letval, _, _, _, Expr}] = + parse_string("let _ = " ++ Text), + Expr. + +round_trip(Text) -> + Contract = parse_string(Text), + Text1 = prettypr:format(aeso_pretty:decls(Contract)), + Contract1 = parse_string(Text1), + NoSrcLoc = remove_line_numbers(Contract), + NoSrcLoc1 = remove_line_numbers(Contract1), + ?assertMatch(NoSrcLoc, diff(NoSrcLoc, NoSrcLoc1)). + +remove_line_numbers({line, _L}) -> {line, 0}; +remove_line_numbers({col, _C}) -> {col, 0}; +remove_line_numbers([H|T]) -> + [remove_line_numbers(H) | remove_line_numbers(T)]; +remove_line_numbers(T) when is_tuple(T) -> + list_to_tuple(remove_line_numbers(tuple_to_list(T))); +remove_line_numbers(M) when is_map(M) -> + maps:from_list(remove_line_numbers(maps:to_list(M))); +remove_line_numbers(X) -> X. + +diff(X, X) -> X; +diff([H | T], [H1 | T1]) -> + [diff(H, H1) | diff(T, T1)]; +diff(T, T1) when tuple_size(T) == tuple_size(T1) -> + list_to_tuple(diff(tuple_to_list(T), tuple_to_list(T1))); +diff(X, Y) -> {X, '/=', Y}. + +tails(Zs) -> lists:foldr(fun(X, [Xs|Xss]) -> [[X|Xs], Xs | Xss] end, [[]], Zs). + diff --git a/test/aeso_scan_tests.erl b/test/aeso_scan_tests.erl new file mode 100644 index 0000000..6e61074 --- /dev/null +++ b/test/aeso_scan_tests.erl @@ -0,0 +1,84 @@ +-module(aeso_scan_tests). + +-include_lib("eunit/include/eunit.hrl"). + +empty_contract_test_() -> + {foreach, + fun() -> + ok + end, + fun(_) -> + ok + end, + [{"Scan an empty contract.", + fun() -> + Text = " ", + {ok, []} = aeso_scan:scan(Text), + ok + end} + ]}. + +all_tokens_test_() -> + {foreach, fun() -> ok end, + fun(_) -> ok end, + [{"Check that we can scan all tokens.", + fun() -> + Tokens = all_tokens(), + Text = string:join(lists:map(fun show_token/1, Tokens), " "), + io:format("~s\n", [Text]), + {ok, Tokens1} = aeso_scan:scan(Text), + true = compare_tokens(Tokens, Tokens1), + ok + end} + ]}. + +all_tokens() -> + Lit = fun(T) -> {T, 1} end, + Tok = fun(T, V) -> {T, 1, V} end, + Hash = list_to_binary([ I * 8 || I <- lists:seq(0, 31) ]), + %% Symbols + lists:map(Lit, [',', '.', ';', '|', ':', '(', ')', '[', ']', '{', '}']) ++ + %% Operators + lists:map(Lit, ['=', '==', '!=', '>', '<', '>=', '=<', '-', '+', '++', '*', '/', mod, ':', '::', '->', '=>', '||', '&&', '!']) ++ + %% Keywords + lists:map(Lit, [contract, type, 'let', switch, rec, 'and']) ++ + %% Comment token (not an actual token), just for tests + [{comment, 0, "// *Comment!\"\n"}, + {comment, 0, "/* bla /* bla bla */*/"}] ++ + %% Literals + [ Lit(true), Lit(false) + , Tok(id, "foo"), Tok(id, "_"), Tok(con, "Foo") + , Tok(hash, Hash) + , Tok(int, 1234567890), Tok(hex, 9876543210) + , Tok(string, <<"bla\"\\\b\e\f\n\r\t\vbla">>) + ]. + +compare_tokens([], []) -> true; +compare_tokens([{T, _} | Ts1], [{T, _} | Ts2]) -> + compare_tokens(Ts1, Ts2); +compare_tokens([{T, _, V} | Ts1], [{T, _, V} | Ts2]) -> + compare_tokens(Ts1, Ts2); +compare_tokens([{comment, _, _} | Ts1], Ts2) -> + compare_tokens(Ts1, Ts2); +compare_tokens(Ts1, Ts2) -> + case length(Ts1) == length(Ts2) of + true -> + {token_mismatch, [ {expected, T1, got, T2} || {T1, T2} <- lists:zip(Ts1, Ts2), T1 /= T2]}; + false -> + {token_mismatch, {expected, Ts1, got, Ts2}} + end. + +fmt(X) -> fmt("~p", X). +fmt(Fmt, X) -> lists:flatten(io_lib:format(Fmt, [X])). + +show_token({T, _}) -> atom_to_list(T); +show_token({id, _, X}) -> X; +show_token({con, _, C}) -> C; +show_token({param, _, P}) -> "@" ++ P; +show_token({string, _, S}) -> fmt(binary_to_list(S)); +show_token({int, _, N}) -> fmt(N); +show_token({hex, _, N}) -> fmt("0x~.16b", N); +show_token({hash, _, <>}) -> fmt("#~.16b", N); +show_token({comment, _, S}) -> S; +show_token({_, _, _}) -> "TODO". + diff --git a/test/aeso_test_utils.erl b/test/aeso_test_utils.erl new file mode 100644 index 0000000..3632551 --- /dev/null +++ b/test/aeso_test_utils.erl @@ -0,0 +1,160 @@ +%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*- +%%%------------------------------------------------------------------- +%%% @copyright (C) 2017, Aeternity Anstalt +%%% @doc Test utilities for the Sophia language tests. +%%% +%%% @end +%%%------------------------------------------------------------------- + +-module(aeso_test_utils). + +-include("apps/aecontract/src/aecontract.hrl"). + +-export([read_contract/1, contract_path/0, pp/1, pp/2, + dump_words/1, show_heap/1, show_heap/2, show_heap_value/1, compile/1]). + +-export([spend/3, get_balance/2, call_contract/6, get_store/1, set_store/2, + aens_lookup/4]). + +contract_path() -> + {ok, Cwd} = file:get_cwd(), + N = length(filename:split(Cwd)), + Rel = ["apps", "aesophia", "test", "contracts"], + %% Try the first matching directory (../)*Rel + Cand = fun(I) -> filename:join(lists:duplicate(I, "..") ++ Rel) end, + case [ Dir || Dir <- lists:map(Cand, lists:seq(0, N)), filelib:is_dir(Dir) ] of + [Dir | _] -> Dir; + [] -> error(failed_to_find_contract_dir) + end. + +%% Read a contract file from the test/contracts directory. +-spec read_contract(string() | atom()) -> string(). +read_contract(Name) -> + {ok, Bin} = file:read_file(filename:join(contract_path(), lists:concat([Name, ".aes"]))), + binary_to_list(Bin). + +pp(Name) -> pp(Name, []). + +pp(Name, Options) -> + case aeso_parser:string(read_contract(Name)) of + {ok, AST} -> + [ io:format("~s\n", [prettypr:format(aeso_pretty:decls(AST))]) || not lists:member(quiet, Options) ]; + {error, {{L, C}, parse_error, Err}} -> + io:format("Parse error at ~p:~p:~p\n~s\n", [Name, L, C, Err]) + end. + +compile(Name) -> + aeso_compiler:from_string(read_contract(Name), + [pp_sophia_code, pp_typed_ast, pp_icode]). + +%% Stack simulator + +simulate([],Stack) -> + Stack; +simulate(['PUSH1',X|More],S) -> + simulate(More,[X|S]); +simulate([Op|More],Stack) -> + simulate(More,simulate(Op,Stack)); +simulate('MSIZE',S) -> + A = new_atom(), + io:format("~p = MSIZE\n",[A]), + [A|S]; +simulate('DUP2',[A,B|S]) -> + [B,A,B|S]; +simulate('DUP3',[A,B,C|S]) -> + [C,A,B,C|S]; +simulate('ADD',[A,B|S]) -> + [add(A,B)|S]; +simulate('MSTORE',[Addr,X|S]) -> + io:format("mem(~p) <- ~p\n",[Addr,X]), + S; +simulate('MLOAD',[Addr|S]) -> + A = new_atom(), + io:format("~p = mem(~p)\n",[A,Addr]), + [A|S]; +simulate('SWAP1',[A,B|S]) -> + [B,A|S]; +simulate('SWAP2',[A,B,C|S]) -> + [C,B,A|S]; +simulate('SUB',[A,B|S]) -> + [{A,'-',B}|S]; +simulate('POP',[_|S]) -> + S. + +add(0,X) -> + X; +add(X,0) -> + X; +add(X,{A,'-',X}) -> + A; +add(X,{A,'+',B}) -> + {A,'+',add(X,B)}; +add(A,B) -> + {A,'+',B}. + +new_atom() -> + catch ets:new(names,[set,public,named_table]), + case ets:lookup(names,index) of + [] -> I = 0; + [{index,I}] -> ok + end, + ets:insert(names,{index,I+1}), + list_to_atom([$a+I]). + +show_heap(Bin) -> + show_heap(0, Bin). + +show_heap(Offs, Bin) -> + Words = dump_words(Bin), + Addrs = lists:seq(0, (length(Words) - 1) * 32, 32), + lists:flatten([io_lib:format("~4b ~p\n", [Addr + Offs, Word]) || {Addr, Word} <- lists:zip(Addrs, Words)]). + +show_heap_value(HeapValue) -> + Maps = aeso_heap:heap_value_maps(HeapValue), + Offs = aeso_heap:heap_value_offset(HeapValue), + Ptr = aeso_heap:heap_value_pointer(HeapValue), + Mem = aeso_heap:heap_value_heap(HeapValue), + Words = dump_words(Mem), + Addrs = lists:seq(Offs, Offs + (length(Words) - 1) * 32, 32), + lists:flatten( + io_lib:format(" Maps: ~p\n Ptr: ~p\n Heap: ~p", + [Maps, Ptr, lists:zip(Addrs, Words)])). + +%% Translate a blob of 256-bit words into readable form. Does a bit of guessing +%% to recover strings. TODO: strings longer than 32 bytes +dump_words(Bin) -> dump_words(Bin, []). + +dump_words(<>, Acc) when N < 32 -> + NotN = (32 - N) * 8, + case W of + <> -> + Str = binary_to_list(S), + case lists:member(0, Str) of + true -> dump_words(<>, [N | Acc]); %% Not a string + false -> dump_words(Rest, [binary_to_list(S), N | Acc]) + end; + _ -> dump_words(<>, [N | Acc]) + end; +dump_words(<>, Acc) -> + dump_words(Rest, [N | Acc]); +dump_words(<<>>, Acc) -> lists:reverse(Acc); +dump_words(Rest, Acc) -> lists:reverse([{error, Rest} | Acc]). + +%% -- Chain API for test ----------------------------------------------------- + +aens_lookup(Name, Key, Type, _S) -> + io:format("aens_lookup(~p, ~p, ~p)\n", [Name, Key, Type]), + {ok, {some, <<0:32/unit:8>>}}. + +spend(Recipient, Amount, S) -> + io:format("+++ SPEND(~p, ~p)\n", [Recipient, Amount]), + {ok, S}. + +get_balance(_, _) -> 1000000. + +call_contract(Contract, Gas, Value, CallData, CallStack, S) -> + io:format("+++ CALL(~p, ~p, ~p, ~p, ~p)\n", [Contract, Gas, Value, CallData, CallStack]), + {ok, <<42:256>>, S}. + +get_store(_) -> #{}. +set_store(_, _) -> ok. diff --git a/test/contract_tests.erl b/test/contract_tests.erl new file mode 100644 index 0000000..5f1762f --- /dev/null +++ b/test/contract_tests.erl @@ -0,0 +1,28 @@ +-module(contract_tests). + +-include_lib("eunit/include/eunit.hrl"). + +make_cmd() -> "make -C " ++ aeso_test_utils:contract_path(). + +contracts_test_() -> + {setup, + fun() -> os:cmd(make_cmd()) end, + fun(_) -> os:cmd(make_cmd() ++ " clean") end, + [ {"Testing the " ++ Contract ++ " contract", + fun() -> + ?assertCmdOutput(Expected, filename:join(aeso_test_utils:contract_path(), Contract ++ "_test")) + end} || {Contract, Expected} <- contracts() ]}. + +contracts() -> + []. + %% [{"voting", + %% "Delegate before vote\n" + %% "Cake: 1\n" + %% "Beer: 2\n" + %% "Winner: Beer\n" + %% "Delegate after vote\n" + %% "Cake: 1\n" + %% "Beer: 2\n" + %% "Winner: Beer\n" + %% }]. + diff --git a/test/contracts/05_greeter.aes b/test/contracts/05_greeter.aes new file mode 100644 index 0000000..04ee5fd --- /dev/null +++ b/test/contracts/05_greeter.aes @@ -0,0 +1,77 @@ +/* https://github.com/fivedogit/solidity-baby-steps/blob/master/contracts/05_greeter.sol + + /* + The following is an extremely basic example of a solidity contract. + It takes a string upon creation and then repeats it when greet() is called. + */ + + contract Greeter // The contract definition. A constructor of the same name will be automatically called on contract creation. + { + address creator; // At first, an empty "address"-type variable of the name "creator". Will be set in the constructor. + string greeting; // At first, an empty "string"-type variable of the name "greeting". Will be set in constructor and can be changed. + + function Greeter(string _greeting) public // The constructor. It accepts a string input and saves it to the contract's "greeting" variable. + { + creator = msg.sender + greeting = _greeting + } + + function greet() constant returns (string) + { + return greeting + } + + function getBlockNumber() constant returns (uint) // this doesn't have anything to do with the act of greeting + { // just demonstrating return of some global variable + return block.number + } + + function setGreeting(string _newgreeting) + { + greeting = _newgreeting + } + + /********** + Standard kill() function to recover funds + **********/ + + function kill() + { + if (msg.sender == creator) // only allow this action if the account sending the signal is the creator + suicide(creator); // kills this contract and sends remaining funds back to creator + } + + } + +*/ + +contract Greeter = + + + /* The creator of the contract will automatically + be set in creator() by the transaction creating the contract. */ + function blockheight : unit => uint + record transaction = { tx : string } + record state = { greeting: string } + record retval = { state: state, + transactions: list(transaction)} + + let state = { greeting = "Hello" } + + let setGreeting = + (greeting: string) => + state{ greeting = greeting } + + + + /* this doesn't have anything to do with the act of greeting + just demonstrating return of some global variable */ + function getBlockNumber() = blockheight() + + /* There is no suicide functionallity in Sophia */ + function kill() = + if ((caller() == creator()) /* only allow this action if the account sending the signal is the creator */ + && (balance() > 0)) /* only creata a transaction if there is something to send */ + state{ transactions = [spend_tx(creator(), balance())] } + else state + diff --git a/test/contracts/Makefile b/test/contracts/Makefile new file mode 100644 index 0000000..0034194 --- /dev/null +++ b/test/contracts/Makefile @@ -0,0 +1,15 @@ + +## Requires ocaml >= 4.02, < 4.06 +## and reason-3.0.0 (opam install reason). + +default : voting_test + +%.ml : %.re + refmt -p ml $< > $@ + + +voting_test : rte.ml voting.ml voting_test.ml + ocamlopt -o $@ $^ + +clean : + rm -f *.cmi *.cmx *.ml *.o voting_test diff --git a/test/contracts/abort_test.aes b/test/contracts/abort_test.aes new file mode 100644 index 0000000..5360930 --- /dev/null +++ b/test/contracts/abort_test.aes @@ -0,0 +1,31 @@ +// A simple test of the abort built-in function. + +contract AbortTest = + + record state = { value : int } + + public function init(v : int) = + { value = v } + + // Aborting + public function do_abort(v : int, s : string) : () = + put_value(v) + revert_abort(s) + + // Accessing the value + public function get_value() = state.value + public function put_value(v : int) = put(state{value = v}) + public function get_values() : list(int) = [state.value] + public function put_values(v : int) = put(state{value = v}) + + // Some basic statistics + public function get_stats(acct : address) = + ( Contract.balance, Chain.balance(acct) ) + + // Abort functions. + private function revert_abort(s : string) = + abort(s) + + // This is still legal but will be stripped out. + // TODO: This function confuses the type inference, so it cannot be present. + //private function abort(s : string) = 42 diff --git a/test/contracts/abort_test_int.aes b/test/contracts/abort_test_int.aes new file mode 100644 index 0000000..970fa5f --- /dev/null +++ b/test/contracts/abort_test_int.aes @@ -0,0 +1,27 @@ +contract Interface = + function do_abort : (int, string) => () + function get_value : () => int + function put_value : (int) => () + function get_values : () => list(int) + function put_values : (int) => () + +contract AbortTestInt = + + record state = {r : Interface, value : int} + + public function init(r : Interface, value : int) = + {r = r, value = value} + + // Aborting + public function do_abort(v : int, s : string) = + put_value(v) + state.r.do_abort(v + 100, s) + + // Accessing the value + public function put_value(v : int) = put(state{value = v}) + public function get_value() = state.value + public function get_values() : list(int) = + state.value :: state.r.get_values() + public function put_values(v : int) = + put_value(v) + state.r.put_values(v + 1000) diff --git a/test/contracts/aens.aes b/test/contracts/aens.aes new file mode 100644 index 0000000..f682d2f --- /dev/null +++ b/test/contracts/aens.aes @@ -0,0 +1,55 @@ +// AENS tests +contract AENSTest = + + // Name resolution + + function resolve_word(name : string, key : string) : option(address) = + AENS.resolve(name, key) + + function resolve_string(name : string, key : string) : option(string) = + AENS.resolve(name, key) + + // Transactions + + function preclaim(addr : address, // Claim on behalf of this account (can be Contract.address) + chash : hash) : () = // Commitment hash + AENS.preclaim(addr, chash) + + function signedPreclaim(addr : address, // Claim on behalf of this account (can be Contract.address) + chash : hash, // Commitment hash + sign : signature) : () = // Signed by addr (if not Contract.address) + AENS.preclaim(addr, chash, signature = sign) + + function claim(addr : address, + name : string, + salt : int) : () = + AENS.claim(addr, name, salt) + + function signedClaim(addr : address, + name : string, + salt : int, + sign : signature) : () = + AENS.claim(addr, name, salt, signature = sign) + + // TODO: update() -- how to handle pointers? + + function transfer(owner : address, + new_owner : address, + name_hash : hash) : () = + AENS.transfer(owner, new_owner, name_hash) + + function signedTransfer(owner : address, + new_owner : address, + name_hash : hash, + sign : signature) : () = + AENS.transfer(owner, new_owner, name_hash, signature = sign) + + function revoke(owner : address, + name_hash : hash) : () = + AENS.revoke(owner, name_hash) + + function signedRevoke(owner : address, + name_hash : hash, + sign : signature) : () = + AENS.revoke(owner, name_hash, signature = sign) + diff --git a/test/contracts/aeproof.aes b/test/contracts/aeproof.aes new file mode 100644 index 0000000..75006eb --- /dev/null +++ b/test/contracts/aeproof.aes @@ -0,0 +1,145 @@ +/* +contract AeToken { + function balanceOf(address addr) returns (uint256) +} + +contract AEProof { + + AeToken aeToken + mapping (bytes32 => Proof) private proofs + mapping (address => bytes32[]) private proofsByOwner + + function AEProof(address tokenAddress) { + aeToken = AeToken(tokenAddress) + } + + struct Proof { + address owner + uint timestamp + uint proofBlock + string comment + string ipfsHash + string document + } + + function notarize(string document, string comment, string ipfsHash) onlyTokenHolder { + var proofHash = calculateHash(document) + var proof = proofs[proofHash] + require(proof.owner == address(0)) + proof.owner = msg.sender + proof.timestamp = block.timestamp + proof.proofBlock = block.number + proof.comment = comment + proof.ipfsHash = ipfsHash + proof.document = document + + proofsByOwner[msg.sender].push(proofHash) + } + + function calculateHash(string document) constant returns (bytes32) { + return sha256(document) + } + + function getProof(string document) constant returns (address owner, uint timestamp, uint proofBlock, string comment, string ipfsHash, string storedDocument) { + var calcHash = calculateHash(document) + var proof = proofs[calcHash] + require(proof.owner != address(0)) + owner = proof.owner + timestamp = proof.timestamp + proofBlock = proof.proofBlock + comment = proof.comment + ipfsHash = proof.ipfsHash + storedDocument = proof.document + } + + function getProofByHash(bytes32 hash) constant returns (address owner, uint timestamp, uint proofBlock, string comment, string ipfsHash, string storedDocument) { + var proof = proofs[hash] + require(proof.owner != address(0)) + owner = proof.owner + timestamp = proof.timestamp + proofBlock = proof.proofBlock + comment = proof.comment + ipfsHash = proof.ipfsHash + storedDocument = proof.document + } + + function hasProof(string document) constant returns (bool) { + var calcHash = calculateHash(document) + var storedProof = proofs[calcHash] + if (storedProof.owner == address(0)) { + return false + } + return true + } + + function getProofsByOwner(address owner) constant returns (bytes32[]) { + return proofsByOwner[owner] + } + + modifier onlyTokenHolder() { + uint balance = aeToken.balanceOf(msg.sender) + require(balance > 0) + _ + } +} +*/ + +// No imports yet +// import contract aetoken +// fun balanceOf(addr : Address) : uint + +contract AEProof = + + record proof = { owner: address + , timestamp: uint + , proofBlock: uint + , comment: string + , ipfsHash: string + , document: string + } + + + record state = { aeToken : aetoken, + proofs : map(uint, proof), + proofsByOwner : map(address, array(uint)) } + + function notarize(document:string, comment:string, ipfsHash:hash) = + let _ = require(aetoken.balanceOf(caller()) > 0) + let proofHash: uint = calculateHash(document) + let proof : proof = Map.get_(proofHash, state().proofs) + let _ = require(proof.owner == #0) + let proof' : proof = proof { owner = caller() + , timestamp = block().timestamp + , proofBlock = block().height + , comment = comment + , ipfsHash = ipfsHash + , document = document + } + state{ proofsByOwner = Map.insert(caller, proofHash, state.proofsByOwner), + proofs = Map.insert(proofHash, proof', state.proofs) } + + + function calculateHash(document: string) : uint = sha256(document) + + function getProof(document) : proof = + let calcHash = calculateHash(document) + let proof = Map.get_(calcHash, state().proofs) + let _ = require(proof.owner != #0) + proof + + function getProofByHash(hash: uint) : proof = + let proof = Map.get_(hash, state().proofs) + let _ = require(proof.owner != #0) + proof + + + function hasProof(document: string) : bool = + let calcHash = calculateHash(document) + let storedProof = Map.get_(calcHash, state().proofs) + storedProof.owner != #0 + + function getProofsByOwner(owner: address): array(uint) = + Map.get(owner, state()) + + function require(x : bool) : unit = if(x) () else abort("false") + diff --git a/test/contracts/all_syntax.aes b/test/contracts/all_syntax.aes new file mode 100644 index 0000000..b3ac623 --- /dev/null +++ b/test/contracts/all_syntax.aes @@ -0,0 +1,51 @@ +// Try to cover all syntactic constructs. + +contract AllSyntaxType = + type typeDecl /* bla */ + type paramTypeDecl('a, 'b) + + /** Multi- + * line + * comment + */ + function foo : _ + +contract AllSyntax = + + type typeDecl = int + type paramTypeDecl('a, 'b) = (('a, 'b) => 'b) => list('a) => 'b => 'b + + record nestedRecord = { x : int } + record recordType = { z : nestedRecord, y : int } + datatype variantType('a) = None | Some('a) + + let valWithType : map(int, int) => option(int) = (m) => Map.get(m, 42) + let valNoType = + if(valWithType(Map.empty) == None) + print(42 mod 10 * 5 / 3) + + function funWithType(x : int, y) : (int, list(int)) = (x, 0 :: [y] ++ []) + function funNoType() = + let foo = (x, y : bool) => + if (! (y && x =< 0x0b || true)) [x] + else [11..20] + let setY(r : recordType) : unit = r{ y = 5 } + let setX(r : recordType, x : int) : recordType = r { z.x = x } // nested record update + let getY(r) = switch(r) {y = y} => y + switch (funWithType(1, -2)) + (x, [y, z]) => bar({x = z, y = -y + - -z * (-1)}) + (x, y :: _) => () + + function bitOperations(x, y) = bnot (0xff00 band x bsl 4 bxor 0xa5a5a5 bsr 4 bor y) + + function mutual() = + let rec recFun(x : int) = mutFun(x) + and mutFun(x) = if(x =< 0) 1 else x * recFun(x - 1) + recFun(0) + + let hash : address = #01ab0fff11 + let b = false + let qcon = Mod.Con + let str = "blabla\nfoo" + let chr = '"' + diff --git a/test/contracts/builtin_bug.aes b/test/contracts/builtin_bug.aes new file mode 100644 index 0000000..54a9fb5 --- /dev/null +++ b/test/contracts/builtin_bug.aes @@ -0,0 +1,12 @@ + +// Compiler failed to detect the map lookup nested in the state update and +// generate the appropriate builtin for it. +contract BuiltinBug = + + record state = {proofs : map(address, list(string))} + + public function init() = {proofs = {}} + + public stateful function createProof(hash : string) = + put( state{ proofs[Call.caller] = hash :: state.proofs[Call.caller] } ) + diff --git a/test/contracts/builtin_map_get_bug.aes b/test/contracts/builtin_map_get_bug.aes new file mode 100644 index 0000000..fff4c85 --- /dev/null +++ b/test/contracts/builtin_map_get_bug.aes @@ -0,0 +1,12 @@ +contract TestContract = + record state = { + _allowed : map(address, map(address, int))} + + public stateful function init() = { + _allowed = {}} + + public stateful function approve(spender: address, value: int) : bool = + + put(state{_allowed[Call.caller][spender] = value}) + + true diff --git a/test/contracts/chain.aes b/test/contracts/chain.aes new file mode 100644 index 0000000..6a5cd8a --- /dev/null +++ b/test/contracts/chain.aes @@ -0,0 +1,13 @@ +// Test more advanced chain interactions + +contract Chain = + + record state = { last_bf : address } + + function init() : state = + {last_bf = Contract.address} + + function miner() = Chain.coinbase + + function save_coinbase() = + put(state{last_bf = Chain.coinbase}) \ No newline at end of file diff --git a/test/contracts/channel_env.aes b/test/contracts/channel_env.aes new file mode 100644 index 0000000..e3d5860 --- /dev/null +++ b/test/contracts/channel_env.aes @@ -0,0 +1,8 @@ +contract ChannelEnv = + public function coinbase() : address = Chain.coinbase + + public function timestamp() : int = Chain.timestamp + + public function block_height() : int = Chain.block_height + + public function difficulty() : int = Chain.difficulty diff --git a/test/contracts/channel_on_chain_contract_name_resolution.aes b/test/contracts/channel_on_chain_contract_name_resolution.aes new file mode 100644 index 0000000..6171286 --- /dev/null +++ b/test/contracts/channel_on_chain_contract_name_resolution.aes @@ -0,0 +1,7 @@ +contract ChannelOnChainContractNameResolution = + + public function can_resolve(name: string, key: string) : bool = + switch(AENS.resolve(name, key) : option(string)) + None => false + Some(_address) => true + diff --git a/test/contracts/channel_on_chain_contract_oracle.aes b/test/contracts/channel_on_chain_contract_oracle.aes new file mode 100644 index 0000000..d62ab41 --- /dev/null +++ b/test/contracts/channel_on_chain_contract_oracle.aes @@ -0,0 +1,48 @@ +contract ChannelOnChainContractOracle = + + type query_t = string + type answer_t = string + type oracle_id = oracle(query_t, answer_t) + type query_id = oracle_query(query_t, answer_t) + + record state = { oracle : oracle_id, + question : string, + bets : map(string, address) + } + + + public function init(oracle: oracle_id, question: string) : state = + { oracle = oracle, + question = question, + bets = {} + } + + public stateful function place_bet(answer: string) = + switch(Map.lookup(answer, state.bets)) + None => + put(state{ bets = state.bets{[answer] = Call.caller}}) + "ok" + Some(_value) => + "bet_already_taken" + + public function query_fee() = + Oracle.query_fee(state.oracle) + + public function get_question(q: query_id) = + Oracle.get_question(state.oracle, q) + + public stateful function resolve(q: query_id) = + switch(Oracle.get_answer(state.oracle, q)) + None => + "no response" + Some(result) => + if(state.question == Oracle.get_question(state.oracle, q)) + switch(Map.lookup(result, state.bets)) + None => + "no winning bet" + Some(winner) => + Chain.spend(winner, Contract.balance) + "ok" + else + "different question" + diff --git a/test/contracts/channel_remote_on_chain_contract_name_resolution.aes b/test/contracts/channel_remote_on_chain_contract_name_resolution.aes new file mode 100644 index 0000000..8847335 --- /dev/null +++ b/test/contracts/channel_remote_on_chain_contract_name_resolution.aes @@ -0,0 +1,9 @@ +contract Remote = + function get : () => int + function can_resolve : (string, string) => bool + +contract RemoteCall = + + function remote_resolve(r : Remote, name: string, key: string) : bool = + r.can_resolve(name, key) + diff --git a/test/contracts/chess.aes b/test/contracts/chess.aes new file mode 100644 index 0000000..571297f --- /dev/null +++ b/test/contracts/chess.aes @@ -0,0 +1,51 @@ + +contract Chess = + + type board = map(int, map(int, string)) + type state = board + + private function get_row(r, m : board) = + Map.lookup_default(r, m, {}) + + private function set_piece(r, c, p, m : board) = + m { [r] = get_row(r, m) { [c] = p } } + + private function get_piece(r, c, m : board) = + Map.lookup(c, get_row(r, m)) + + private function from_list(xs, m : board) = + switch(xs) + [] => m + (r, c, p) :: xs => from_list(xs, set_piece(r, c, p, m)) + + function init() = + from_list([ (2, 1, "white pawn"), (7, 1, "black pawn") + , (2, 2, "white pawn"), (7, 2, "black pawn") + , (2, 3, "white pawn"), (7, 3, "black pawn") + , (2, 4, "white pawn"), (7, 4, "black pawn") + , (2, 5, "white pawn"), (7, 5, "black pawn") + , (2, 6, "white pawn"), (7, 6, "black pawn") + , (2, 7, "white pawn"), (7, 7, "black pawn") + , (2, 8, "white pawn"), (7, 8, "black pawn") + , (1, 1, "white rook"), (8, 1, "black rook") + , (1, 2, "white knight"), (8, 2, "black knight") + , (1, 3, "white bishop"), (8, 3, "black bishop") + , (1, 4, "white queen"), (8, 4, "black queen") + , (1, 5, "white king"), (8, 5, "black king") + , (1, 6, "white bishop"), (8, 6, "black bishop") + , (1, 7, "white knight"), (8, 7, "black knight") + , (1, 8, "white rook"), (8, 8, "black rook") + ], {}) + + function piece(r, c) = get_piece(r, c, state) + + function move_piece(r, c, r1, c1) = + switch(piece(r, c)) + Some(p) => put(set_piece(r1, c1, p, state)) + + function destroy_piece(r, c) = + put(state{ [r] = Map.delete(c, get_row(r, state)) }) + + function delete_row(r) = + put(Map.delete(r, state)) + diff --git a/test/contracts/complex_types.aes b/test/contracts/complex_types.aes new file mode 100644 index 0000000..dae0675 --- /dev/null +++ b/test/contracts/complex_types.aes @@ -0,0 +1,86 @@ + +contract Remote = + function up_to : (int) => list(int) + function sum : (list(int)) => int + function some_string : () => string + function pair : (int, string) => (int, string) + function squares : (int) => list((int, int)) + function filter_some : (list(option(int))) => list(int) + function all_some : (list(option(int))) => option(list(int)) + +contract ComplexTypes = + + record state = { worker : Remote } + + function init(worker) = {worker = worker} + + function sum_acc(xs, n) = + switch(xs) + [] => n + x :: xs => sum_acc(xs, x + n) + + // Sum a list of integers + function sum(xs : list(int)) = + sum_acc(xs, 0) + + function up_to_acc(n, xs) = + switch(n) + 0 => xs + _ => up_to_acc(n - 1, n :: xs) + + function up_to(n) = up_to_acc(n, []) + + record answer('a) = {label : string, result : 'a} + + function remote_triangle(worker, n) : answer(int) = + let xs = worker.up_to(gas = 100000, n) + let t = worker.sum(xs) + { label = "answer:", result = t } + + function remote_list(n) : list(int) = + state.worker.up_to(n) + + function some_string() = "string" + + function remote_string() : string = + state.worker.some_string() + + function pair(x : int, y : string) = (x, y) + + function remote_pair(n : int, s : string) : (int, string) = + state.worker.pair(gas = 10000, n, s) + + function map(f, xs) = + switch(xs) + [] => [] + x :: xs => f(x) :: map(f, xs) + + function squares(n) = + map((i) => (i, i * i), up_to(n)) + + function remote_squares(n) : list((int, int)) = + state.worker.squares(n) + + // option types + + function filter_some(xs : list(option(int))) : list(int) = + switch(xs) + [] => [] + None :: ys => filter_some(ys) + Some(x) :: ys => x :: filter_some(ys) + + function remote_filter_some(xs : list(option(int))) : list(int) = + state.worker.filter_some(xs) + + function all_some(xs : list(option(int))) : option(list(int)) = + switch(xs) + [] => Some([]) + None :: ys => None + Some(x) :: ys => + switch(all_some(ys)) + Some(xs) => Some(x :: xs) + None => None + + function remote_all_some(xs : list(option(int))) : option(list(int)) = + state.worker.all_some(gas = 10000, xs) + diff --git a/test/contracts/contract_types.aes b/test/contracts/contract_types.aes new file mode 100644 index 0000000..99ecfca --- /dev/null +++ b/test/contracts/contract_types.aes @@ -0,0 +1,20 @@ + +contract OtherContract = + + function multiply : (int, int) => int + +contract ThisContract = + + record state = { server : OtherContract, n : int } + + function init(server : OtherContract) = + { server = server, n = 2 } + + function square() = + put(state{ n @ n = state.server.multiply(value = 100, n, n) }) + + function get_n() = state.n + + function tip_server() = + Chain.spend(state.server.address, Call.value) + diff --git a/test/contracts/counter.aes b/test/contracts/counter.aes new file mode 100644 index 0000000..4015cef --- /dev/null +++ b/test/contracts/counter.aes @@ -0,0 +1,9 @@ + +contract Counter = + + record state = { value : int } + + function init(val) = { value = val } + function get() = state.value + function tick() = put(state{ value = state.value + 1 }) + diff --git a/test/contracts/dutch_auction.aes b/test/contracts/dutch_auction.aes new file mode 100644 index 0000000..6106146 --- /dev/null +++ b/test/contracts/dutch_auction.aes @@ -0,0 +1,43 @@ +// +// Dutch auction example +// +contract DutchAuction = + + record state = { start_amount : int, + start_height : int, + dec : int, + beneficiary : address, + sold : bool } + + // Add to work around current lack of predefined functions + private function spend(to, amount) = + let total = Contract.balance + Chain.spend(to, amount) + total - amount + + private function require(b : bool, err : string) = + if(!b) abort(err) + + // TTL set by user on posting contract, typically (start - end ) div dec + public function init(beneficiary, start, decrease) : state = + require(start > 0 && decrease > 0, "bad args") + { start_amount = start, + start_height = Chain.block_height, + beneficiary = beneficiary, + dec = decrease, + sold = false } + + // -- API + + // We are the buyer... interesting case to buy for someone else and keep 10% + public stateful function bid() = + require( !(state.sold), "sold") + let cost = + state.start_amount - (Chain.block_height - state.start_height) * state.dec + require( Contract.balance >= cost, "no money") + +// transaction(SpendTx({recipient = state.beneficiary, +// amount = cost })) // or self.balance ** burn money ** + spend(state.beneficiary, cost) + spend(Call.caller, Contract.balance) + put(state{sold = true}) diff --git a/test/contracts/environment.aes b/test/contracts/environment.aes new file mode 100644 index 0000000..3b48a40 --- /dev/null +++ b/test/contracts/environment.aes @@ -0,0 +1,69 @@ + +// Testing primitives for accessing the block chain environment +contract Interface = + function contract_address : () => address + function call_origin : () => address + function call_caller : () => address + function call_value : () => int + +contract Environment = + + record state = {remote : Interface} + + function init(remote) = {remote = remote} + + function set_remote(remote) = put({remote = remote}) + + // -- Information about the this contract --- + + // Address + function contract_address() : address = Contract.address + function nested_address(who) : address = + who.contract_address(gas = 1000) + + // Balance + function contract_balance() : int = Contract.balance + + // -- Information about the current call --- + + // Origin + function call_origin() : address = Call.origin + function nested_origin() : address = + state.remote.call_origin() + + // Caller + function call_caller() : address = Call.caller + function nested_caller() : address = + state.remote.call_caller() + + // Value + function call_value() : int = Call.value + function nested_value(value : int) : int = + state.remote.call_value(value = value / 2) + + // Gas price + function call_gas_price() : int = Call.gas_price + + // -- Information about the chain --- + + // Account balances + function get_balance(acct : address) : int = Chain.balance(acct) + + // Block hash + function block_hash(height : int) : int = Chain.block_hash(height) + + // Coinbase + function coinbase() : address = Chain.coinbase + + // Block timestamp + function timestamp() : int = Chain.timestamp + + // Block height + function block_height() : int = Chain.block_height + + // Difficulty + function difficulty() : int = Chain.difficulty + + // Gas limit + function gas_limit() : int = Chain.gas_limit + diff --git a/test/contracts/erc20_token.aes b/test/contracts/erc20_token.aes new file mode 100644 index 0000000..f2c5cca --- /dev/null +++ b/test/contracts/erc20_token.aes @@ -0,0 +1,90 @@ +contract ERC20Token = + record state = { + totalSupply : int, + decimals : int, + name : string, + symbol : string, + balances : map(address, int), + allowed : map(address, map(address,int)), + // Logs, remove when native Events are there + transfer_log : list((address,address,int)), + approval_log : list((address,address,int))} + + // init(100000000, 10, "Token Name", "TKN") + public stateful function init(_totalSupply : int, _decimals : int, _name : string, _symbol : string ) = { + totalSupply = _totalSupply, + decimals = _decimals, + name = _name, + symbol = _symbol, + balances = {[Call.caller] = _totalSupply }, // creator gets all Tokens + allowed = {}, + // Logs, remove when native Events are there + transfer_log = [], + approval_log = []} + + public stateful function totalSupply() : int = state.totalSupply + public stateful function decimals() : int = state.decimals + public stateful function name() : string = state.name + public stateful function symbol() : string = state.symbol + + public stateful function balanceOf(tokenOwner : address ) : int = + Map.lookup_default(tokenOwner, state.balances, 0) + + public stateful function transfer(to : address, tokens : int) = + put( state{balances[Call.caller] = sub(state.balances[Call.caller], tokens) }) + put( state{balances[to] = add(Map.lookup_default(to, state.balances, 0), tokens) }) + transferEvent(Call.caller, to, tokens) + true + + public stateful function approve(spender : address, tokens : int) = + // allowed[Call.caller] field must have a value! + ensure_allowed(Call.caller) + put( state{allowed[Call.caller][spender] = tokens} ) + approvalEvent(Call.caller, spender, tokens) + true + + public stateful function transferFrom(from : address, to : address, tokens : int) = + put( state{ balances[from] = sub(state.balances[from], tokens) }) + put( state{ allowed[from][Call.caller] = sub(state.allowed[from][Call.caller], tokens) }) + put( state{ balances[to] = add(balanceOf(to), tokens) }) + transferEvent(from, to, tokens) + true + + public function allowance(_owner : address, _spender : address) : int = + state.allowed[_owner][_spender] + + public stateful function getTransferLog() : list((address,address,int)) = + state.transfer_log + public stateful function getApprovalLog() : list((address,address,int)) = + state.approval_log + + // + // Private Functions + // + + private function ensure_allowed(key : address) = + switch(Map.lookup(key, state.allowed)) + None => put(state{allowed[key] = {}}) + Some(_) => () + + private function transferEvent(from : address, to : address, tokens : int) = + let e = (from, to, tokens) + put( state{transfer_log = e :: state.transfer_log }) + e + + private function approvalEvent(from : address, to : address, tokens : int) = + let e = (from, to, tokens) + put( state{approval_log = e :: state.approval_log }) + e + + private function require(b : bool, err : string) = + if(!b) abort(err) + + private function sub(_a : int, _b : int) : int = + require(_b =< _a, "Error") + _a - _b + + private function add(_a : int, _b : int) : int = + let c : int = _a + _b + require(c >= _a, "Error") + c diff --git a/test/contracts/events.aes b/test/contracts/events.aes new file mode 100644 index 0000000..cb2c4b0 --- /dev/null +++ b/test/contracts/events.aes @@ -0,0 +1,22 @@ +contract Events = + type alias_int = int + type alias_address = address + type alias_string = string + + datatype event = + Event1(indexed alias_int, indexed int, string) + | Event2(alias_string, indexed alias_address) + // | BadEvent1(indexed string, string) + // | BadEvent2(indexed int, int) + + function f1(x : int, y : string) = + Chain.event(Event1(x, x+1, y)) + + function f2(s : string) = + Chain.event(Event2(s, Call.caller)) + + function f3(x : int) = + Chain.event(Event1(x, x + 2, Int.to_str(x + 7))) + + function i2s(i : int) = Int.to_str(i) + function a2s(a : address) = Address.to_str(a) diff --git a/test/contracts/exploits.aes b/test/contracts/exploits.aes new file mode 100644 index 0000000..bbc16e1 --- /dev/null +++ b/test/contracts/exploits.aes @@ -0,0 +1,6 @@ + +contract Exploits = + + // We'll hack the bytecode of this changing the return type to string. + function pair(n : int) = (n, 0) + diff --git a/test/contracts/factorial.aes b/test/contracts/factorial.aes new file mode 100644 index 0000000..447196e --- /dev/null +++ b/test/contracts/factorial.aes @@ -0,0 +1,17 @@ +// An implementation of the factorial function where each recursive +// call is to another contract. Not the cheapest way to compute factorial. +contract FactorialServer = + function fac : (int) => int + +contract Factorial = + + record state = {worker : FactorialServer} + + function init(worker) = {worker = worker} + + function set_worker(worker) = put(state{worker = worker}) + + function fac(x : int) : int = + if(x == 0) 1 + else x * state.worker.fac(x - 1) + diff --git a/test/contracts/fundme.aes b/test/contracts/fundme.aes new file mode 100644 index 0000000..0a73113 --- /dev/null +++ b/test/contracts/fundme.aes @@ -0,0 +1,65 @@ +/* + * A simple crowd-funding example + */ +contract FundMe = + + record spend_args = { recipient : address, + amount : int } + + record state = { contributions : map(address, int), + total : int, + beneficiary : address, + deadline : int, + goal : int } + + private function require(b : bool, err : string) = + if(!b) abort(err) + + private function spend(args : spend_args) = + Chain.spend(args.recipient, args.amount) + + public function init(beneficiary, deadline, goal) : state = + { contributions = {}, + beneficiary = beneficiary, + deadline = deadline, + total = 0, + goal = goal } + + private function is_contributor(addr) = + Map.member(addr, state.contributions) + + public stateful function contribute() = + if(Chain.block_height >= state.deadline) + spend({ recipient = Call.caller, amount = Call.value }) // Refund money + false + else + let amount = + Map.lookup_default(Call.caller, state.contributions, 0) + Call.value + put(state{ contributions[Call.caller] = amount, + total @ tot = tot + Call.value }) + true + + public stateful function withdraw() = + if(Chain.block_height < state.deadline) + abort("Cannot withdraw before deadline") + if(Call.caller == state.beneficiary) + withdraw_beneficiary() + elif(is_contributor(Call.caller)) + withdraw_contributor() + else + abort("Not a contributor or beneficiary") + + private stateful function withdraw_beneficiary() = + require(state.total >= state.goal, "Project was not funded") + spend({recipient = state.beneficiary, + amount = Contract.balance }) + put(state{ beneficiary = #0 }) + + private stateful function withdraw_contributor() = + if(state.total >= state.goal) + abort("Project was funded") + let to = Call.caller + spend({recipient = to, + amount = state.contributions[to]}) + put(state{ contributions @ c = Map.delete(to, c) }) + diff --git a/test/contracts/identity.aes b/test/contracts/identity.aes new file mode 100644 index 0000000..5af2425 --- /dev/null +++ b/test/contracts/identity.aes @@ -0,0 +1,3 @@ + +contract Identity = + function main (x:int) = x diff --git a/test/contracts/init_error.aes b/test/contracts/init_error.aes new file mode 100644 index 0000000..9d81a3a --- /dev/null +++ b/test/contracts/init_error.aes @@ -0,0 +1,9 @@ +contract Remote = + function missing : (int) => int + +contract Init_error = + + record state = {value : int} + + function init(r : Remote, x : int) = + {value = r.missing(x)} diff --git a/test/contracts/map_of_maps.aes b/test/contracts/map_of_maps.aes new file mode 100644 index 0000000..49599c1 --- /dev/null +++ b/test/contracts/map_of_maps.aes @@ -0,0 +1,36 @@ + +contract MapOfMaps = + + type board = map(int, map(int, string)) + type map2('a, 'b, 'c) = map('a, map('b, 'c)) + + record state = { big1 : map2(string, string, string), + big2 : map2(string, string, string), + small1 : map(string, string), + small2 : map(string, string) } + + private function empty_state() = + { big1 = {}, big2 = {}, + small1 = {}, small2 = {} } + + function init() = empty_state() + + function setup_state() = + let small = {["key"] = "val"} + put({ big1 = {["one"] = small}, + big2 = {["two"] = small}, + small1 = small, + small2 = small }) + + // -- Garbage collection of inner map when outer map is garbage collected + function test1_setup() = + let inner = {["key"] = "val"} + put(empty_state() { big1 = {["one"] = inner} }) + + function test1_execute() = + put(state{ big1 = {} }) + + function test1_check() = + state.big1 + + diff --git a/test/contracts/maps.aes b/test/contracts/maps.aes new file mode 100644 index 0000000..02d4b13 --- /dev/null +++ b/test/contracts/maps.aes @@ -0,0 +1,100 @@ +contract Maps = + + record pt = {x : int, y : int} + record state = { map_i : map(int, pt), + map_s : map(string, pt) } + + function init() = { map_i = {}, map_s = {} } + + function get_state() = state + + // {[k] = v} + function map_i() = + { [1] = {x = 1, y = 2}, + [2] = {x = 3, y = 4}, + [3] = {x = 5, y = 6} } + function map_s() = + { ["one"] = {x = 1, y = 2}, + ["two"] = {x = 3, y = 4}, + ["three"] = {x = 5, y = 6} } + function map_state_i() = put(state{ map_i = map_i() }) + function map_state_s() = put(state{ map_s = map_s() }) + + // m[k] + function get_i(k, m : map(int, pt)) = m[k] + function get_s(k, m : map(string, pt)) = m[k] + function get_state_i(k) = get_i(k, state.map_i) + function get_state_s(k) = get_s(k, state.map_s) + + // m[k = v] + function get_def_i(k, v, m : map(int, pt)) = m[k = v] + function get_def_s(k, v, m : map(string, pt)) = m[k = v] + function get_def_state_i(k, v) = get_def_i(k, v, state.map_i) + function get_def_state_s(k, v) = get_def_s(k, v, state.map_s) + + // m{[k] = v} + function set_i(k, p, m : map(int, pt)) = m{ [k] = p } + function set_s(k, p, m : map(string, pt)) = m{ [k] = p } + function set_state_i(k, p) = put(state{ map_i = set_i(k, p, state.map_i) }) + function set_state_s(k, p) = put(state{ map_s = set_s(k, p, state.map_s) }) + + // m{f[k].x = v} + function setx_i(k, x, m : map(int, pt)) = m{ [k].x = x } + function setx_s(k, x, m : map(string, pt)) = m{ [k].x = x } + function setx_state_i(k, x) = put(state{ map_i[k].x = x }) + function setx_state_s(k, x) = put(state{ map_s[k].x = x }) + + // m{[k] @ x = v } + function addx_i(k, d, m : map(int, pt)) = m{ [k].x @ x = x + d } + function addx_s(k, d, m : map(string, pt)) = m{ [k].x @ x = x + d } + function addx_state_i(k, d) = put(state{ map_i[k].x @ x = x + d }) + function addx_state_s(k, d) = put(state{ map_s[k].x @ x = x + d }) + + // m{[k = def] @ x = v } + function addx_def_i(k, v, d, m : map(int, pt)) = m{ [k = v].x @ x = x + d } + function addx_def_s(k, v, d, m : map(string, pt)) = m{ [k = v].x @ x = x + d } + + // Map.member + function member_i(k, m : map(int, pt)) = Map.member(k, m) + function member_s(k, m : map(string, pt)) = Map.member(k, m) + function member_state_i(k) = member_i(k, state.map_i) + function member_state_s(k) = member_s(k, state.map_s) + + // Map.lookup + function lookup_i(k, m : map(int, pt)) = Map.lookup(k, m) + function lookup_s(k, m : map(string, pt)) = Map.lookup(k, m) + function lookup_state_i(k) = lookup_i(k, state.map_i) + function lookup_state_s(k) = lookup_s(k, state.map_s) + + // Map.lookup_default + function lookup_def_i(k, m : map(int, pt), def : pt) = + Map.lookup_default(k, m, def) + function lookup_def_s(k, m : map(string, pt), def : pt) = + Map.lookup_default(k, m, def) + function lookup_def_state_i(k, def) = lookup_def_i(k, state.map_i, def) + function lookup_def_state_s(k, def) = lookup_def_s(k, state.map_s, def) + + // Map.delete + function delete_i(k, m : map(int, pt)) = Map.delete(k, m) + function delete_s(k, m : map(string, pt)) = Map.delete(k, m) + function delete_state_i(k) = put(state{ map_i = delete_i(k, state.map_i) }) + function delete_state_s(k) = put(state{ map_s = delete_s(k, state.map_s) }) + + // Map.size + function size_i(m : map(int, pt)) = Map.size(m) + function size_s(m : map(string, pt)) = Map.size(m) + function size_state_i() = size_i(state.map_i) + function size_state_s() = size_s(state.map_s) + + // Map.to_list + function tolist_i(m : map(int, pt)) = Map.to_list(m) + function tolist_s(m : map(string, pt)) = Map.to_list(m) + function tolist_state_i() = tolist_i(state.map_i) + function tolist_state_s() = tolist_s(state.map_s) + + // Map.from_list + function fromlist_i(xs : list((int, pt))) = Map.from_list(xs) + function fromlist_s(xs : list((string, pt))) = Map.from_list(xs) + function fromlist_state_i(xs) = put(state{ map_i = fromlist_i(xs) }) + function fromlist_state_s(xs) = put(state{ map_s = fromlist_s(xs) }) + diff --git a/test/contracts/maps_benchmark.aes b/test/contracts/maps_benchmark.aes new file mode 100644 index 0000000..fd8204d --- /dev/null +++ b/test/contracts/maps_benchmark.aes @@ -0,0 +1,29 @@ + +contract MapUpdater = + function update_map : (int, string, map(int, string)) => map(int, string) + +contract Benchmark = + + record state = { updater : MapUpdater, + map : map(int, string) } + + function init(u, m) = { updater = u, map = m } + + function set_updater(u) = put(state{ updater = u }) + + function update_map(k : int, v : string, m) = m{ [k] = v } + + function update(a : int, b : int, v : string) = + if (a > b) () + else + put(state{ map[a] = v }) + update(a + 1, b, v) + + function get(k) = state.map[k] + function noop() = () + + function benchmark(k, v) = + let m = state.updater.update_map(k, v, state.map) + put(state{ map = m }) + m + diff --git a/test/contracts/minimal_init.aes b/test/contracts/minimal_init.aes new file mode 100644 index 0000000..28e618a --- /dev/null +++ b/test/contracts/minimal_init.aes @@ -0,0 +1,6 @@ +contract MinimalInit = + + record state = {foo : int} + + function init() = + { foo = 0 } diff --git a/test/contracts/multi_sig.aes b/test/contracts/multi_sig.aes new file mode 100644 index 0000000..6c8c9ff --- /dev/null +++ b/test/contracts/multi_sig.aes @@ -0,0 +1,123 @@ +/* Multi-signature wallet from + https://github.com/ethereum/dapp-bin/blob/master/wallet/wallet.sol + +*/ + +contract MultiSig = + + record pending_state = { yetNeeded : uint, ownersDone : uint, index : uint } + + datatype event = + Confirmation (address, hash) // of { .owner : Address, .operation : Hash } + | Revoke (address, hash) // of { .owner : Address, .operation : Hash } + | OwnerChanged (address, address) // of { .oldOwner : Address, .newOwner : Address } + | OwnerAdded (address) // of { .newOwner : Address } + | OwnerRemoved (address) // of { .removedOwner : Address } + | ReqChanged (uint) // of { .newReq : uint } + + let maxOwners : uint = 250 + + record state = { nRequired : uint + , nOwners : uint + , owners : map(uint, address) + , ownerIndex : map(address, uint) + , pending : map(hash, pending_state) + , pendingIndex : list(address) } + + function init (owners : list(address), nRequired : uint) : state = + let n = length(owners) + 1 + { nRequired = nRequired, + nOwners = n, + owners = Map.from_list(List.zip([1..n], caller() :: owners)), + ownerIndex = Map.from_list(List.zip(caller() :: owners, [1..n])) } + + function lookup(map, key) = + switch(Map.get(key, map)) + None => abort("not found") + Some(value) => value + + function revoke(operation : hash) = + let ownerIx = lookup(state.ownerIndex, caller()) + let pending = lookup(state.pendingIndex, operation) + let ownerIxBit = 1 bsl (ownerIx - 1) + let _ = require(pending.ownersDone band ownerIxBit > 0) + let pending' = pending { yetNeeded = pending.yetNeeded + 1 + , ownersDone = pending.ownersDone - ownerIxBit } + put(state{ pendingIndex.operator = pending' }) + event(Revoke(caller, operation)) + + + datatype check_pending = CheckOk(state) | CheckFail(state) + + function changeOwner(fromOwner : address, toOwner : address) = + switch(check_pending(callhash())) + CheckFail(state') => { state = state' } + CheckOk(state') => + if(isOwner(toOwner)) put(state') + else + switch(Map.get(fromOwner, state.ownerIndex)) + None => { state = state' } + Some(ownerIx) => + { state = state' { owners = Map.insert(ownerIx, toOwner, state'.owners) + , ownerIndex = Map.delete(fromOwner, Map.insert(toOwner, ownerIx, state'.ownerIndex)) + , pending = Map.empty + , pendingIx = [] }, + events = [OwnerChanged(fromOwner, toOwner)] } + + function addOwner(newOwner : address) = + let _ = require (!isOwner(newOwner)) + switch(check_pending(callhash())) + CheckFail(state') => { state = state' } + CheckOk(state') => + if(state.nOwners >= maxOwners) () /* TODO */ + else + let nOwners' = state'.nOwners + 1 + { state = state' { owners = Map.insert(nOwners', newOwner, state'.owners) + , ownerIndex = Map.insert(newOwner, nOwners', state'.ownerIndex) + , pending = Map.empty + , pendingIx = [] }, + event = [OwnerAdded(newOwner)] } + + function removeOwner(oldOwner : address) = + let _ = require(isOwner(oldOwner)) + let _ = require(state.nRequired > state.nOwners - 1) + switch(check_pending(callhash())) + CheckFail(state') => { state = state' } + CheckOk(state') => + let ownerIx = lookup(state'.ownerIndex, oldOwner) + { state = state' { owners = Map.delete(ownerIx, state'.owners) + , ownerIndex = Map.delete(newOwner, state'.ownerIndex) + , pending = Map.empty + , pendingIx = [] }, + event = [OwnerRemoved(oldOwner)] } + + function changeRequirement(newReq : uint) = + let _ = require(newReq =< state.nOwners) + switch(check_pending(callhash())) + CheckFail(state') => { state = state' } + CheckOk(state') => + { state = state' { nRequired = newReq + , pending = Map.empty + , pendingIx = [] }, + event = [ReqChanged(newReq)] } + + + function getOwner(ownerIx0 : uint) = + lookup(state.owners, ownerIx0 + 1) + + function isOwner(owner : address) = + switch(Map.get(owner, state.ownerIndex)) + None => false + Some(_) => true + + function hasConfirmed(operation : hash, owner : address) = + switch(Map.get(operation, state.pending)) + None => false + Some(pending) => + let _ = require(isOwner(owner)) + let ownerIx = lookup(state.ownerIndex, owner) + let ownerIxBit = 1 bsl (ownerIx - 1) + (pending.ownersDone band ownerIxBit) != 0 + + /* Leave the rest for now... */ + diff --git a/test/contracts/multiplication_server.aes b/test/contracts/multiplication_server.aes new file mode 100644 index 0000000..859cd44 --- /dev/null +++ b/test/contracts/multiplication_server.aes @@ -0,0 +1,7 @@ + +contract MultiplicationServer = + + function multiply(x : int, y : int) = + switch(Call.value >= 100) + true => x * y + diff --git a/test/contracts/name_clash.aes b/test/contracts/name_clash.aes new file mode 100644 index 0000000..199f433 --- /dev/null +++ b/test/contracts/name_clash.aes @@ -0,0 +1,16 @@ + +contract NameClash = + + function double_proto : () => int + function double_proto : () => int + + function proto_and_def : int => int + function proto_and_def(n) = n + 1 + + function double_def(x) = x + function double_def(y) = 0 + + // abort, put and state are builtin + function abort() : int = 0 + function put(x) = x + function state(x, y) = x + y diff --git a/test/contracts/operators.aes b/test/contracts/operators.aes new file mode 100644 index 0000000..9ac89fb --- /dev/null +++ b/test/contracts/operators.aes @@ -0,0 +1,44 @@ +// - + * / mod arithmetic operators +// bnot band bor bxor bsl bsr bitwise operators +// ! && || logical operators +// == != < > =< >= comparison operators +// :: ++ list operators + +contract Operators = + function int_op(a : int, b : int, op : string) = + switch(op) + "+" => a + b + "-" => a - b + "*" => a * b + "/" => a / b + "mod" => a mod b + "^" => a ^ b + "bnot" => bnot a + "band" => a band b + "bor" => a bor b + "bxor" => a bxor b + "bsl" => a bsl b + "bsr" => a bsr b + + function bool_op(a : bool, b : bool, op : string) = + switch(op) + "!" => !a + "&&" => a && b + "||" => a || b + + function cmp_op(a : int, b : int, op : string) = + switch(op) + "==" => a == b + "!=" => a != b + "<" => a < b + ">" => a > b + "=<" => a =< b + ">=" => a >= b + + function cons(a, l) = a :: l + function concat(l1, l2) = l1 ++ l2 + + function hash(s) = // String.sha3(s) + let x = String.sha3(s) + let y = String.sha3(s) + (x, y) diff --git a/test/contracts/oracles.aes b/test/contracts/oracles.aes new file mode 100644 index 0000000..4f125fc --- /dev/null +++ b/test/contracts/oracles.aes @@ -0,0 +1,112 @@ +contract Oracles = + + type fee = int + type ttl = Chain.ttl + + type query_t = string + type answer_t = int + + type oracle_id = oracle(query_t, answer_t) + type query_id = oracle_query(query_t, answer_t) + + function registerOracle(acct : address, + qfee : fee, + ttl : ttl) : oracle_id = + Oracle.register(acct, qfee, ttl) + + function registerIntIntOracle(acct : address, + qfee : fee, + ttl : ttl) : oracle(int, int) = + Oracle.register(acct, qfee, ttl) + + function registerStringStringOracle(acct : address, + qfee : fee, + ttl : ttl) : oracle(string, string) = + Oracle.register(acct, qfee, ttl) + + function signedRegisterOracle(acct : address, + sign : signature, + qfee : fee, + ttl : ttl) : oracle_id = + Oracle.register(acct, qfee, ttl, signature = sign) + + function queryFee(o : oracle_id) : fee = + Oracle.query_fee(o) + + function createQuery(o : oracle_id, + q : query_t, + qfee : fee, + qttl : ttl, + rttl : ttl) : query_id = + require(qfee =< Call.value, "insufficient value for qfee") + Oracle.query(o, q, qfee, qttl, rttl) + + // Do not use in production! + function unsafeCreateQuery(o : oracle_id, + q : query_t, + qfee : fee, + qttl : ttl, + rttl : ttl) : query_id = + Oracle.query(o, q, qfee, qttl, rttl) + + // Do not use in production! + function unsafeCreateQueryThenErr(o : oracle_id, + q : query_t, + qfee : fee, + qttl : ttl, + rttl : ttl) : query_id = + let res = Oracle.query(o, q, qfee, qttl, rttl) + require(qfee >= 100000000000000000, "causing a late error") + res + + function extendOracle(o : oracle_id, + ttl : ttl) : () = + Oracle.extend(o, ttl) + + function signedExtendOracle(o : oracle_id, + sign : signature, // Signed oracle address + ttl : ttl) : () = + Oracle.extend(o, signature = sign, ttl) + + function respond(o : oracle_id, + q : query_id, + r : answer_t) : () = + Oracle.respond(o, q, r) + + function signedRespond(o : oracle_id, + q : query_id, + sign : signature, + r : answer_t) : () = + Oracle.respond(o, q, signature = sign, r) + + function getQuestion(o : oracle_id, + q : query_id) : query_t = + Oracle.get_question(o, q) + + function hasAnswer(o : oracle_id, + q : query_id) = + switch(Oracle.get_answer(o, q)) + None => false + Some(_) => true + + function getAnswer(o : oracle_id, + q : query_id) : option(answer_t) = + Oracle.get_answer(o, q) + + datatype complexQuestion = Why(int) | How(string) + datatype complexAnswer = NoAnswer | Answer(complexQuestion, string, int) + + function complexOracle(question) = + let o = Oracle.register(Contract.address, 0, FixedTTL(1000)) : oracle(complexQuestion, complexAnswer) + let q = Oracle.query(o, question, 0, RelativeTTL(100), RelativeTTL(100)) + Oracle.respond(o, q, Answer(question, "magic", 1337)) + Oracle.get_answer(o, q) + + function signedComplexOracle(question, sig) = + let o = Oracle.register(signature = sig, Contract.address, 0, FixedTTL(1000)) : oracle(complexQuestion, complexAnswer) + let q = Oracle.query(o, question, 0, RelativeTTL(100), RelativeTTL(100)) + Oracle.respond(o, q, Answer(question, "magic", 1337), signature = sig) + Oracle.get_answer(o, q) + + private function require(b : bool, err : string) = + if(!b) abort(err) diff --git a/test/contracts/oracles_err.aes b/test/contracts/oracles_err.aes new file mode 100644 index 0000000..7a5aa22 --- /dev/null +++ b/test/contracts/oracles_err.aes @@ -0,0 +1,11 @@ +contract OraclesErr = + + public function unsafeCreateQueryThenErr( + o : oracle(string, int), + q : string, + qfee : int, + qttl : Chain.ttl, + rttl : Chain.ttl) : oracle_query(string, int) = + let x = Oracle.query(o, q, qfee, qttl, rttl) + switch(0) 1 => () + x // Never reached. diff --git a/test/contracts/oracles_gas.aes b/test/contracts/oracles_gas.aes new file mode 100644 index 0000000..7e75a67 --- /dev/null +++ b/test/contracts/oracles_gas.aes @@ -0,0 +1,24 @@ +contract OraclesGas = + + type fee = int + type question_t = string + type answer_t = int + + public function happyPathWithAllBuiltinsAtSameHeight( + qfee : fee, + ottl : Chain.ttl, + ettl : Chain.ttl, + qttl : Chain.ttl, + rttl : Chain.ttl + ) = + let question = "why" + let answer = 42 + let o = Oracle.register(Contract.address, qfee, ottl) : oracle(question_t, answer_t) + Oracle.extend(o, ettl) + require(qfee =< Call.value, "insufficient value for qfee") + let q = Oracle.query(o, question, qfee, qttl, rttl) + Oracle.respond(o, q, answer) + () + + private function require(b : bool, err : string) = + if(!b) abort(err) diff --git a/test/contracts/oracles_no_vm.aes b/test/contracts/oracles_no_vm.aes new file mode 100644 index 0000000..ad32066 --- /dev/null +++ b/test/contracts/oracles_no_vm.aes @@ -0,0 +1,37 @@ +contract Oracles = + + type fee = int + type ttl = Chain.ttl + + type query_t = string + type answer_t = string + + type oracle_id = oracle(query_t, answer_t) + type query_id = oracle_query(query_t, answer_t) + + function createQuery(o : oracle_id, + q : query_t, + qfee : fee, + qttl : ttl, + rttl : ttl) : query_id = + require(qfee =< Call.value, "insufficient value for qfee") + Oracle.query(o, q, qfee, qttl, rttl) + + + function respond(o : oracle_id, + q : query_id, + sign : signature, + r : answer_t) : () = + Oracle.respond(o, q, signature = sign, r) + + + function getQuestion(o : oracle_id, + q : query_id) : query_t = + Oracle.get_question(o, q) + + function getAnswer(o : oracle_id, + q : query_id) : option(answer_t) = + Oracle.get_answer(o, q) + + private function require(b : bool, err : string) = + if(!b) abort(err) diff --git a/test/contracts/polymorphism_test.aes b/test/contracts/polymorphism_test.aes new file mode 100644 index 0000000..a6c4c91 --- /dev/null +++ b/test/contracts/polymorphism_test.aes @@ -0,0 +1,16 @@ + +contract Identity = + + function zip_with(f, xs, ys) = + switch((xs, ys)) + (x :: xs, y :: ys) => f(x, y) :: zip_with(f, xs, ys) + _ => [] + + // Check that we can use zip_with at different types + + function foo() = + zip_with((x, y) => x + y, [1, 2, 3], [4, 5, 6, 7]) + + function bar() = + zip_with((x, y) => if(x) y else 0, [true, false, true, false], [1, 2, 3]) + diff --git a/test/contracts/primitive_map.aes b/test/contracts/primitive_map.aes new file mode 100644 index 0000000..73c2e41 --- /dev/null +++ b/test/contracts/primitive_map.aes @@ -0,0 +1,57 @@ + +contract MapServer = + + function insert : (string, string, map(string, string)) => map(string, string) + function delete : (string, map(string, string)) => map(string, string) + +contract PrimitiveMaps = + + record state = { remote : MapServer, + map : map(string, string), + map2 : map(string, string) } + + function init(r) = + let m = {} + { remote = r, map = m, map2 = m } + + function set_remote(r) = put(state{ remote = r }) + + function insert(k, v, m) : map(string, string) = m{ [k] = v } + function delete(k, m) : map(string, string) = Map.delete(k, m) + + function remote_insert(k, v, m) = + state.remote.insert(k, v, m) + + function remote_delete(k, m) = + state.remote.delete(k, m) + + function get_state_map() = state.map + function set_state_map(m) = put(state{ map = m }) + + function clone_state() = put(state{ map2 = state.map }) + + function insert_state(k, v) = put(state{ map @ m = m { [k] = v } }) + function delete_state(k) = put(state{ map @ m = Map.delete(k, m) }) + function lookup_state(k) = Map.lookup(k, state.map) + + function double_insert_state(k, v1, v2) = + put(state{ map @ m = m { [k] = v1 }, + map2 @ m = m { [k] = v2 } }) + + function test() = + let m = {} : map(string, string) + let m1 = m { ["foo"] = "value_of_foo", + ["bla"] = "value_of_bla" } + let m2 = Map.delete("foo", m1) + let m3 = m2 { ["bla"] = "new_value_of_bla" } + [Map.lookup("foo", m), Map.lookup("bla", m), + Map.lookup("foo", m1), Map.lookup("bla", m1), + Map.lookup("foo", m2), Map.lookup("bla", m2), + Map.lookup("foo", m3), Map.lookup("bla", m3)] + + function return_map() = + Map.delete("goo", {["foo"] = "bar", ["goo"] = "gaa"}) + + function argument_map(m : map(string, string)) = + m["foo"] + diff --git a/test/contracts/reason/rte.re b/test/contracts/reason/rte.re new file mode 100644 index 0000000..a3f827c --- /dev/null +++ b/test/contracts/reason/rte.re @@ -0,0 +1,60 @@ + +/* Primitive types */ +type address = string; +type uint = int; +exception Abort; + +type env = + { mutable _caller : address + }; + +let env = { _caller: "" }; + +/* Builtin functions */ +let caller() : address = env._caller; +let abort() = raise(Abort); + +let call(who, fn) = { + env._caller = who; + let res = try(fn()) { | e => env._caller = ""; raise(e) }; + env._caller = ""; + res +}; + +/* Library functions */ +let require(x) = x ? () : abort(); + +/* -- Managing contract state ------------------------------------------------ */ + +type state_rep('s) = { mutable state : option('s) }; + +let newStateRep() : state_rep('s) = { state: None }; + +exception UninitializedState; +exception ReinitializedState; + +let getState(rep) = + switch(rep.state) { + | None => raise(UninitializedState) + | Some(s) => s + }; + +let setState(rep, s) = + switch(rep.state) { + | None => rep.state = Some(s) + | Some(_) => raise(ReinitializedState) + }; + +module type Contract = { + type state; + type args; + let init : args => state; + let stateRep : state_rep(state); +}; + +module Setup = (C : Contract) => { + let init(creator, args) = + setState(C.stateRep, call(creator, () => C.init(args))); + let reset() = C.stateRep.state = None; +}; + diff --git a/test/contracts/reason/voting.re b/test/contracts/reason/voting.re new file mode 100644 index 0000000..5736350 --- /dev/null +++ b/test/contracts/reason/voting.re @@ -0,0 +1,126 @@ + +open Rte; + +/* Contract type */ +module type Voting = { + type state; + type args = list(string); + let stateRep : state_rep(state); + + let init : args => state; + let giveRightToVote : address => unit; + let delegate : address => unit; + let vote : int => unit; + let winnerName : unit => string; + let currentTally : unit => list((string, int)); +}; + +/* Contract implementation */ +module Voting : Voting = { + + /* Not so nice */ + module AddrKey = { type t = address; let compare = Pervasives.compare }; + module AddrMap = Map.Make(AddrKey); + type addr_map('a) = AddrMap.t('a); + + /* Types */ + + type proposal = + { name: string + , mutable voteCount: uint + }; + + type voter = + { mutable weight: int + , mutable delegate: option(address) + , mutable vote: option(int) + }; + + type state = + { chairPerson: address + , mutable voters: addr_map(voter) + , proposals: list(proposal) + }; + + /* Initialization */ + type args = list(string); + let init(proposalNames: args): state = + { chairPerson: caller(), + voters: AddrMap.empty, + proposals: List.map((name) => {name: name, voteCount: 0}, proposalNames) + }; + + /* Boilerplate */ + let stateRep = newStateRep(); + let state() = getState(stateRep); + + let initVoter() = { weight: 1, delegate: None, vote: None }; + + let giveRightToVote(voter: address) = { + require(caller() == state().chairPerson); + require(!AddrMap.mem(voter, state().voters)); + state().voters = AddrMap.add(voter, initVoter(), state().voters); + () + }; + + let rec delegateChain(delegate: address) = { + require(delegate != caller()); /* Delegation loop! */ + let voter = AddrMap.find(delegate, state().voters); + switch(voter.delegate) { + | None => delegate; + | Some(d) => delegateChain(d) + } + }; + + let addVote(candidate, weight) = { + let proposal = List.nth(state().proposals, candidate); + proposal.voteCount = proposal.voteCount + weight; + }; + + let delegateVote(delegateTo: address, weight: uint) = { + let voter = AddrMap.find(delegateTo, state().voters); + switch(voter.vote) { + | Some(vote) => addVote(vote, weight) + | None => voter.weight = voter.weight + weight + } + }; + + let delegate(delegateTo: address) = { + require(delegateTo != caller()); + let voter = AddrMap.find(caller(), state().voters); + require(voter.vote == None); + let finalDelegate = delegateChain(delegateTo); + voter.vote = Some(0); /* Hm... */ + voter.delegate = Some(finalDelegate); + delegateVote(finalDelegate, voter.weight) + }; + + let vote(candidate: uint) = { + let voter = AddrMap.find(caller(), state().voters); + require(voter.vote == None); + voter.vote = Some(candidate); + addVote(candidate, voter.weight); + }; + + let rec winningProposal'(current, rest) = + switch(rest) { + | [] => current; + | [p, ...ps] => winningProposal'(p.voteCount > current.voteCount ? p : current, ps) + }; + + /* const */ + let winningProposal() : proposal = { + switch(state().proposals) { + | [] => abort() + | [p, ...ps] => winningProposal'(p, ps) + } + }; + + /* const */ + let winnerName() = winningProposal().name; + + /* const */ + let currentTally() = + List.map((p) => (p.name, p.voteCount), state().proposals); + +} diff --git a/test/contracts/reason/voting_test.re b/test/contracts/reason/voting_test.re new file mode 100644 index 0000000..85cd587 --- /dev/null +++ b/test/contracts/reason/voting_test.re @@ -0,0 +1,42 @@ + +open Rte; +open Voting; + +let creator = "0x123"; +let voter1 = "0x1001"; +let voter2 = "0x1002"; +let voter3 = "0x1003"; +let other = "0xffff"; + +module SetupVote = Setup(Voting); +open Voting; + +let print_tally() = { + let tally = call(other, () => currentTally()); + List.map(((name, count)) => Printf.printf("%s: %d\n", name, count), tally); + let winner = call(other, () => winnerName()); + Printf.printf("Winner: %s\n", winner); +}; + +Printf.printf("Delegate before vote\n"); +SetupVote.init(creator, ["Cake", "Beer"]); +call(creator, () => giveRightToVote(voter1)); +call(creator, () => giveRightToVote(voter2)); +call(creator, () => giveRightToVote(voter3)); +call(voter3, () => delegate(voter1)); +call(voter1, () => vote(1)); +call(voter2, () => vote(0)); +print_tally(); + +SetupVote.reset(); + +Printf.printf("Delegate after vote\n"); +SetupVote.init(creator, ["Cake", "Beer"]); +call(creator, () => giveRightToVote(voter1)); +call(creator, () => giveRightToVote(voter2)); +call(creator, () => giveRightToVote(voter3)); +call(voter1, () => vote(1)); +call(voter3, () => delegate(voter1)); +call(voter2, () => vote(0)); +print_tally(); + diff --git a/test/contracts/remote_call.aes b/test/contracts/remote_call.aes new file mode 100644 index 0000000..6c7998f --- /dev/null +++ b/test/contracts/remote_call.aes @@ -0,0 +1,27 @@ + +contract Remote1 = + function main : (int) => int + +contract Remote2 = + function call : (Remote1, int) => int + +contract Remote3 = + function get : () => int + function tick : () => () + +contract RemoteCall = + + function call(r : Remote1, x : int) : int = + r.main(gas = 10000, value = 10, x) + + function staged_call(r1 : Remote1, r2 : Remote2, x : int) = + r2.call(r1, x) + + function increment(r3 : Remote3) = + r3.tick() + + function get(r3 : Remote3) = + r3.get() + + function plus(x, y) = x + y + diff --git a/test/contracts/remote_gas_test.aes b/test/contracts/remote_gas_test.aes new file mode 100644 index 0000000..ee88cf2 --- /dev/null +++ b/test/contracts/remote_gas_test.aes @@ -0,0 +1,20 @@ +contract Remote1 = + function set : (int) => int + +contract RemoteCall = + record state = { i : int } + + function init(x) = { i = x } + + function set( x : int) : int = + let old = state.i + put(state{ i = x }) + old + + function call(r : Remote1, x : int, g : int) : int = + r.set(gas = g, value = 10, x) + + function get() = state.i + + + diff --git a/test/contracts/remote_oracles.aes b/test/contracts/remote_oracles.aes new file mode 100644 index 0000000..1b921c0 --- /dev/null +++ b/test/contracts/remote_oracles.aes @@ -0,0 +1,99 @@ +contract Oracles = + + function registerOracle : + (address, + int, + Chain.ttl) => oracle(string, int) + + function createQuery : + (oracle(string, int), + string, + int, + Chain.ttl, + Chain.ttl) => oracle_query(string, int) + + function unsafeCreateQuery : + (oracle(string, int), + string, + int, + Chain.ttl, + Chain.ttl) => oracle_query(string, int) + + function respond : + (oracle(string, int), + oracle_query(string, int), + int) => () + +contract OraclesErr = + + function unsafeCreateQueryThenErr : + (oracle(string, int), + string, + int, + Chain.ttl, + Chain.ttl) => oracle_query(string, int) + +contract RemoteOracles = + + public function callRegisterOracle( + r : Oracles, + acct : address, + qfee : int, + ttl : Chain.ttl) : oracle(string, int) = + r.registerOracle(acct, qfee, ttl) + + public function callCreateQuery( + r : Oracles, + value : int, + o : oracle(string, int), + q : string, + qfee : int, + qttl : Chain.ttl, + rttl : Chain.ttl) : oracle_query(string, int) = + require(value =< Call.value, "insufficient value") + r.createQuery(value = value, o, q, qfee, qttl, rttl) + + // Do not use in production! + public function callUnsafeCreateQuery( + r : Oracles, + value : int, + o : oracle(string, int), + q : string, + qfee : int, + qttl : Chain.ttl, + rttl : Chain.ttl) : oracle_query(string, int) = + r.unsafeCreateQuery(value = value, o, q, qfee, qttl, rttl) + + // Do not use in production! + public function callUnsafeCreateQueryThenErr( + r : OraclesErr, + value : int, + o : oracle(string, int), + q : string, + qfee : int, + qttl : Chain.ttl, + rttl : Chain.ttl) : oracle_query(string, int) = + r.unsafeCreateQueryThenErr(value = value, o, q, qfee, qttl, rttl) + + // Do not use in production! + public function callUnsafeCreateQueryAndThenErr( + r : Oracles, + value : int, + o : oracle(string, int), + q : string, + qfee : int, + qttl : Chain.ttl, + rttl : Chain.ttl) : oracle_query(string, int) = + let x = r.unsafeCreateQuery(value = value, o, q, qfee, qttl, rttl) + switch(0) 1 => () + x // Never reached. + + public function callRespond( + r : Oracles, + o : oracle(string, int), + q : oracle_query(string, int), + qr : int) = + r.respond(o, q, qr) + + private function require(b : bool, err : string) = + if(!b) abort(err) diff --git a/test/contracts/remote_state.aes b/test/contracts/remote_state.aes new file mode 100644 index 0000000..c9bfff3 --- /dev/null +++ b/test/contracts/remote_state.aes @@ -0,0 +1,23 @@ +contract RemoteState = + record rstate = { i : int, s : string, m : map(int, int) } + + function look_at(s : rstate) = () + function return_s(big : bool) = + let x = "short" + let y = "______longer_string_at_least_32_bytes_long___________longer_string_at_least_32_bytes_long___________longer_string_at_least_32_bytes_long_____" + if(big) y else x + function return_m(big : bool) = + let x = { [1] = 2 } + let y = { [1] = 2, [3] = 4, [5] = 6 } + if(big) y else x + + function get(s : rstate) = s + function get_i(s : rstate) = s.i + function get_s(s : rstate) = s.s + function get_m(s : rstate) = s.m + + function fun_update_i(s : rstate, ni) = s{ i = ni } + function fun_update_s(s : rstate, ns) = s{ s = ns } + function fun_update_m(s : rstate, nm) = s{ m = nm } + function fun_update_mk(s : rstate, k, v) = s{ m = s.m{[k] = v} } + diff --git a/test/contracts/remote_type_check.aes b/test/contracts/remote_type_check.aes new file mode 100644 index 0000000..ed62fe9 --- /dev/null +++ b/test/contracts/remote_type_check.aes @@ -0,0 +1,22 @@ +contract Remote = + function id : ('a) => 'a + function missing : ('a) => 'a + function wrong_type : (string) => string + +contract Main = + + function id(x : int) = + x + + function wrong_type(x : int) = + x + + function remote_id(r : Remote, x) = + r.id(x) + + function remote_missing(r : Remote, x) = + r.missing(x) + + function remote_wrong_type(r : Remote, x) = + r.wrong_type(x) + diff --git a/test/contracts/remote_value_on_err.aes b/test/contracts/remote_value_on_err.aes new file mode 100644 index 0000000..4a5de6a --- /dev/null +++ b/test/contracts/remote_value_on_err.aes @@ -0,0 +1,21 @@ +contract ValueOnErr = + function err : () => int + function ok : () => int + +contract RemoteValueOnErr = + + public function callErr( + r : ValueOnErr, + value : int) : int = + r.err(value = value) + + public function callErrLimitGas( + r : ValueOnErr, + value : int, + gas : int) : int = + r.err(value = value, gas = gas) + + public function callOk( + r : ValueOnErr, + value : int) : int = + r.ok(value = value) diff --git a/test/contracts/simple.aes b/test/contracts/simple.aes new file mode 100644 index 0000000..9e1d28a --- /dev/null +++ b/test/contracts/simple.aes @@ -0,0 +1,3 @@ + +contract Simple = + type t = int => int diff --git a/test/contracts/simple_storage.aes b/test/contracts/simple_storage.aes new file mode 100644 index 0000000..3b1a9e9 --- /dev/null +++ b/test/contracts/simple_storage.aes @@ -0,0 +1,29 @@ +/* Example from Solidity by Example + http://solidity.readthedocs.io/en/develop/introduction-to-smart-contracts.html + + The Solidity code: + + contract SimpleStorage { + uint storedData + + function set(uint x) { + storedData = x + } + + function get() constant returns (uint) { + return storedData + } + } +*/ + +contract SimpleStorage = + + type event = int + record state = { data : int } + + function init(value : int) : state = { data = value } + + function get() : int = state.data + + function set(value : int) = + put(state{data = value}) diff --git a/test/contracts/spend_test.aes b/test/contracts/spend_test.aes new file mode 100644 index 0000000..21140e4 --- /dev/null +++ b/test/contracts/spend_test.aes @@ -0,0 +1,26 @@ + +contract SpendContract = + function withdraw : (int) => int + +contract SpendTest = + + function spend(to, amount) = + let total = Contract.balance + Chain.spend(to, amount) + total - amount + + function withdraw(amount) : int = + spend(Call.caller, amount) + + function withdraw_from(account, amount) = + account.withdraw(amount) + withdraw(amount) + + function spend_from(from, to, amount) = + from.withdraw(amount) + Chain.spend(to, amount) + Chain.balance(to) + + function get_balance() = Contract.balance + function get_balance_of(a) = Chain.balance(a) + diff --git a/test/contracts/stack.aes b/test/contracts/stack.aes new file mode 100644 index 0000000..842be97 --- /dev/null +++ b/test/contracts/stack.aes @@ -0,0 +1,29 @@ +// Testing more interesting state types +contract Stack = + + type stack('a) = list('a) + + record state = { stack : stack(string), + size : int } + + function init(ss : list(string)) = { stack = ss, size = length(ss) } + + private function length(xs) = + switch(xs) + [] => 0 + _ :: xs => length(xs) + 1 + + stateful function pop() : string = + switch(state.stack) + s :: ss => + put(state{ stack = ss, size = state.size - 1 }) + s + + stateful function push(s) = + put(state{ stack = s :: state.stack, size = state.size + 1 }) + state.size + + function all() = state.stack + + function size() = state.size + diff --git a/test/contracts/state_handling.aes b/test/contracts/state_handling.aes new file mode 100644 index 0000000..737e644 --- /dev/null +++ b/test/contracts/state_handling.aes @@ -0,0 +1,67 @@ +contract Remote = + function look_at : (state) => () + function return_s : (bool) => string + function return_m : (bool) => map(int, int) + function get : (state) => state + function get_i : (state) => int + function get_s : (state) => string + function get_m : (state) => map(int, int) + + function fun_update_i : (state, int) => state + function fun_update_s : (state, string) => state + function fun_update_m : (state, map(int, int)) => state + function fun_update_mk : (state, int, int) => state + +contract StateHandling = + record state = { i : int, s : string, m : map(int, int) } + + function init(r : Remote, i : int) = + let state0 = { i = 0, s = "undefined", m = {} } + r.fun_update_i(state0, i) + + function read() = state + function read_i() = state.i + function read_s() = state.s + function read_m() = state.m + + function update(new_state : state) = put(new_state) + function update_i(new_i) = put(state{ i = new_i }) + function update_s(new_s) = put(state{ s = new_s }) + function update_m(new_m) = put(state{ m = new_m }) + + function pass_it(r : Remote) = r.look_at(state) + function nop(r : Remote) = put(state{ i = state.i }) + function return_it_s(r : Remote, big : bool) = + let x = r.return_s(big) + String.length(x) + function return_it_m(r : Remote, big : bool) = + let x = r.return_m(big) + Map.size(x) + + function pass(r : Remote) = r.get(state) + function pass_i(r : Remote) = r.get_i(state) + function pass_s(r : Remote) = r.get_s(state) + function pass_m(r : Remote) = r.get_m(state) + + function pass_update_i(r : Remote, i) = r.fun_update_i(state, i) + function pass_update_s(r : Remote, s) = r.fun_update_s(state, s) + function pass_update_m(r : Remote, m) = r.fun_update_m(state, m) + + function remote_update_i (r : Remote, i) = put(r.fun_update_i(state, i)) + function remote_update_s (r : Remote, s) = put(r.fun_update_s(state, s)) + function remote_update_m (r : Remote, m) = put(r.fun_update_m(state, m)) + function remote_update_mk(r : Remote, k, v) = put(r.fun_update_mk(state, k, v)) + + // remote called + function look_at(s : state) = () + + function get(s : state) = s + function get_i(s : state) = s.i + function get_s(s : state) = s.s + function get_m(s : state) = s.m + + function fun_update_i(st, ni) = st{ i = ni } + function fun_update_s(st, ns) = st{ s = ns } + function fun_update_m(st, nm) = st{ m = nm } + function fun_update_mk(st, k, v) = st{ m = st.m{[k] = v} } + diff --git a/test/contracts/strings.aes b/test/contracts/strings.aes new file mode 100644 index 0000000..629a0f9 --- /dev/null +++ b/test/contracts/strings.aes @@ -0,0 +1,4 @@ +contract Strings = + function str_len(s) = String.length(s) + function str_concat(s1, s2) = String.concat(s1, s2) + diff --git a/test/contracts/test.aes b/test/contracts/test.aes new file mode 100644 index 0000000..b70f153 --- /dev/null +++ b/test/contracts/test.aes @@ -0,0 +1,101 @@ + +contract Identity = + // type xy = {x:int, y:int} + // type xz = {x:int, z:int} + // type yz = {y:int, z:int} + record point = {x:int,y:int} + record cp('a) = {color: string, p:'a} + //type intpoint = point(int) + // //if (x==42) 1 else (x*x) + // } + //let baz() = {age:3, name:(4:int)} + //let foo(a,b,c) = c + // let rec fac(n) = if((n:int)==0) 1 else (n*fac(n-1)) + // and main(x) = x::[x+1] + // let lentr(l) = lent(0,l) + // let rec len(l) = + // switch(l) { + // | [] => 0 + // | x::xs => 1+len(xs) + // } + // let lent(n,l) = + // switch (l) { + // | [] => n + // | (x::xs) => lent(n+1,xs) + // } + // let rec app(a,b) = + // switch(a) { + // | [] => b + // | (x::xs) => x::app(xs,b) + // } + // let rec revt(l,r) = + // switch(l) { + // | [] => r + // | x::xs => revt(xs,x::r) + // } + // let rev(l) = revt(l,[]) + // let main(x:int) = { + // switch(rev([1,2,3])) { + // | h::_ => h + // } + // } + //let fac(n:int) = { + // if (n==0) 1 else (n*fac(n-1)) + //} + //let main(x) = switch((12,34)) { + //| (13,_) => x + //| (_,a) => x+a + // | y => y+1 + // } + //let main(x) = ({y:0>1, x:x==0}:point(bool)) + //let main(x) = x + //let main(x) = len(1::2::[]) + //let main(x) = ((x,x):list('a)) + // let main(x) = switch("a") { + // | "b" => 0 + // | "a" => 1 + // | "c" => 2 + // } + //let main(x) = x.color+1 + //let main(x) = switch(({x:x, y:x+1}:cp(int))) { + // | {y:xx} => xx + // } + //let main(x) = {x:0, y:1, z:2} + // let id(x) = x + // let double(x) = x+x + // let pair(x) = (1,2) + // let unit(x) = () + // let tuples(x) = ((1,x),(2,3,4)) + // let singleton(x) = [x] + // let rec seq(n) = if (n==0) [] else (app(seq(n-1),[n])) + // let idString(s:string) = s + // let pairString(s:string) = (s,s) + // let revStrings(ss:list(string))=rev(ss) + // let makePoint(x,y) = {x:x, y:y} + // let getx(x) = x.x + // let updatex(p,x) = p{x:x} + // let quad(x) = {let y=x+x; let z=y+y; z;} + // let noblock(x) = {x; x} + // let unit(x) = () + // let foo(x) = switch (x) { + // | y => y+1 +// } + // let p(x) = {color:"blue", p:{x:x, y:x+1}} + //let twice(f,x) = f(f(x)) + // let twice(f,x) = f(f(x)) + // let double(x) = x+x + // let main(x) = twice((y=>y+y),x) + // let rec map(f,xs) = switch(xs) { + // | [] => [] + // | (x::ys) => f(x)::map(f,ys) + // } + // let id(x) = x + // let main(xs) = map(double,xs) + function z(f,x) = x + private function s(n) = (f,x)=>f(n(f,x)) + private function add(m,n) = (f,x)=>m(f,n(f,x)) + function main(_) = + let three=s(s(s(z))) + add(three,three) + (((i)=>i+1),0) + diff --git a/test/contracts/type_errors.aes b/test/contracts/type_errors.aes new file mode 100644 index 0000000..d106686 --- /dev/null +++ b/test/contracts/type_errors.aes @@ -0,0 +1,42 @@ + +contract Test = + + record r = { x : map(string, string), y : int } + record r' = { y : string } + record r2 = { z : int, w : int } + record r3 = { x : int, z : int } + + function set_x(r : r, z) = r{ x["foo"] @ x = x + 1 } + + function bla(m : map(string, int)) = { [0] = "bla", ["foo"] = "" } + + function foo(r) = r { y = 0 } + function bar() = { y = "foo", z = 0 } + function baz() = { y = "foo", w = 0 } + + function foo1() = zz + + function test1() : string = { y = 0 } + function test2(x : string) = x { y = 0 } + function test3(x : string) = x { y @ y = y + 1 } + function test4(x : string) : int = x.y + + function test5(xs) = + switch(xs) + x :: x => x + [] => 0 + + function case_pat(xs) = + switch(xs) + [] => 0 + x :: xs => "x" + + function foo2(m : map(string, int)) = m{ [1] = "bla" } + + function bad_if(x, y : int, w : int, z : string) = + if(x) y + elif(x) w + else z + + function type_error(r, x) = + set_x(set_x(x, r), x) diff --git a/test/contracts/upfront_charges.aes b/test/contracts/upfront_charges.aes new file mode 100644 index 0000000..74041d0 --- /dev/null +++ b/test/contracts/upfront_charges.aes @@ -0,0 +1,6 @@ +contract UpfrontCharges = + record state = { b : int } // For enabling retrieval of sender balance observed inside init. + public function init() : state = { b = b() } + public function initialSenderBalance() : int = state.b + public function senderBalance() : int = b() + private function b() = Chain.balance(Call.origin) diff --git a/test/contracts/value_on_err.aes b/test/contracts/value_on_err.aes new file mode 100644 index 0000000..43cbb93 --- /dev/null +++ b/test/contracts/value_on_err.aes @@ -0,0 +1,7 @@ +contract ValueOnErr = + + public function err() : int = + switch(0) 1 => 5 + + public function ok() : int = + 11 diff --git a/test/contracts/variant_types.aes b/test/contracts/variant_types.aes new file mode 100644 index 0000000..bdd88a9 --- /dev/null +++ b/test/contracts/variant_types.aes @@ -0,0 +1,29 @@ + +contract VariantTypes = + + datatype state = Started(started_state) | Stopped + + record started_state = {owner : address, balance : int, color : color} + + datatype color = Red | Green | Blue | Grey(int) + + function init() = Stopped + + function require(b) = if(!b) abort("required") + + function start(bal : int) = + switch(state) + Stopped => put(Started({owner = Call.caller, balance = bal, color = Grey(0)})) + + function stop() = + switch(state) + Started(st) => + require(Call.caller == st.owner) + put(Stopped) + st.balance + + function get_color() = switch(state) Started(st) => st.color + function set_color(c) = switch(state) Started(st) => put(Started(st{color = c})) + + function get_state() = state + diff --git a/test/contracts/voting.aes b/test/contracts/voting.aes new file mode 100644 index 0000000..8560488 --- /dev/null +++ b/test/contracts/voting.aes @@ -0,0 +1,97 @@ + +/* Contract type */ +contract VotingType = + type state + function init : list(string) => state + + function giveRightToVote : address => unit + function delegate : address => unit + function vote : int => unit + function winnerName : unit => string + function currentTally : unit => list((string, int)) + +/* Contract implementation */ +contract Voting = + + // Types + record proposal = + { name : string + , voteCount : uint + } + + datatype vote = NotVoted | Voted(int) | Delegated(address) + + record voter = + { weight : int + , vote : vote + } + + record state = + { chairPerson : address + , voters : map(address, voter) + , proposals : list(proposal) + } + + // Initialization + function init(proposalNames: list(string)): state = + { chairPerson = caller(), + voters = Map.empty, + proposals = List.map((name) => {name = name, voteCount = 0}, proposalNames) } + + function initVoter() = { weight = 1, vote = NotVoted} + + function giveRightToVote(voter: address) = + require(caller() == state.chairPerson) + require(!Map.mem(voter, state.voters)) + put(state{ voters = Map.add(voter, initVoter(), state.voters) }) + + function delegateChain(delegate: address) = + require(delegate != caller()) /* Delegation loop! */ + let voter = Map.find(delegate, state.voters) + switch(voter.vote) + Delegated(d) => delegateChain(d) + _ => delegate + + function addVote(candidate, weight) = + let proposal = List.nth(state.proposals, candidate) + proposal{ voteCount = proposal.voteCount + weight } + + function delegateVote(delegateTo: address, weight: uint) = + let voter = Map.find(delegateTo, state.voters) + switch(voter.vote) + Voted(vote) => addVote(vote, weight) + Delegated(_) => abort("impossible") // impossible + NotVoted => voter{ weight = voter.weight + weight } + + function delegate(delegateTo: address) = + require(delegateTo != caller()) + let voter = Map.find(caller(), state.voters) + require(voter.vote == NotVoted) + let finalDelegate = delegateChain(delegateTo) + let voter' = voter{ vote = Delegated(finalDelegate) } + delegateVote(finalDelegate, voter.weight) + + function vote(candidate: uint) = + let voter = Map.find(caller(), state.voters) + require(voter.vote == NotVoted) + let voter' = voter{ vote = Voted(candidate) } + addVote(candidate, voter.weight) + + function winningProposal'(current, rest) = + switch(rest) + [] => current + p :: ps => winningProposal'(if (p.voteCount > current.voteCount) p else current, ps) + + // const + function winningProposal() : proposal = + switch(state.proposals) + [] => abort("none") + p :: ps => winningProposal'(p, ps) + + // const + function winnerName() = winningProposal().name + + // const + function currentTally() = + List.map((p) => (p.name, p.voteCount), state.proposals) + diff --git a/test/contracts/withdrawal.aes b/test/contracts/withdrawal.aes new file mode 100644 index 0000000..b80f5c9 --- /dev/null +++ b/test/contracts/withdrawal.aes @@ -0,0 +1,56 @@ +/* Example from Solidity by Example + http://solidity.readthedocs.io/en/develop/common-patterns.html + + contract WithdrawalContract { + address public richest + uint public mostSent + + mapping (address => uint) pendingWithdrawals + + function WithdrawalContract() payable { + richest = msg.sender + mostSent = msg.value + } + + function becomeRichest() payable returns (bool) { + if (msg.value > mostSent) { + pendingWithdrawals[richest] += msg.value + richest = msg.sender + mostSent = msg.value + return true + } else { + return false + } + } + + function withdraw() { + uint amount = pendingWithdrawals[msg.sender] + // Remember to zero the pending refund before + // sending to prevent re-entrancy attacks + pendingWithdrawals[msg.sender] = 0 + msg.sender.transfer(amount) + } + } + +*/ + +contract WithdrawalContract = + + record state = { richest : address, + mostSent : uint, + pendingWithdrawals : map(address, uint) } + + function becomeRichest() : result(bool) = + if (call().value > state.mostSent) + let totalAmount : uint = Map.get_(state.richest, pendingWithdrawals) + call().value + {state = state{ pendingWithdrawals = Map.insert(state.richest, call().value, state.pendingWithdrawals), + richest = call().sender, + mostSent = call().value }, + result = true} + else + {result = false} + + function withdraw() = + let amount : uint = Map.get_(call().sender, state.pendingWithdrawals) + { state.pendingWithdrawals = Map.insert(call().sender, 0, state.pendingWithdrawals), + transactions = spend_tx(amount, call().sender) }