QPQ-AG/sophia
10
0
Fork 0
Code Issues 41 Pull Requests 5 Actions Packages Projects Releases 16 Wiki Activity

First test work commit, don't touch

Browse Source
This commit is contained in:
Robert Virding 2018-12-22 01:23:40 +01:00
parent 3ceb8c38db
commit d4d02fd576
97 changed files with 10599 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

191
LICENSE Normal file
View File

@ -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 <rvirding@gmail.com>.
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.

15
include/aeso_heap.hrl Normal file
View File

@ -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()} }).

13
rebar.config Normal file
View File

@ -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]}
]}.

255
src/aeso_abi.erl Normal file
View File

@ -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, <<TypeHashInt:?HASH_SIZE/unit:8>>} -> {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, <<HashInt:?HASH_SIZE/unit:8>>};
{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:?HASH_SIZE/unit:8>>}) -> N;
old_ast_to_erlang({hash, _, <<Hi:256, Lo:256>>}) -> {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 ]).

27
src/aeso_ast.erl Normal file
View File

@ -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]).

1662
src/aeso_ast_infer_types.erl Normal file
View File

File diff suppressed because it is too large Load Diff

711
src/aeso_ast_to_icode.erl Normal file
View File

@ -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
<<Value:32/unit:8>> -> %% address
#integer{value = Value};
<<Hi:32/unit:8, Lo:32/unit:8>> -> %% 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),
<<TypeHash:256>> = 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},
<<TH:256>> = 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}.

510
src/aeso_builtins.erl Normal file
View File

@ -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}.

259
src/aeso_compiler.erl Normal file
View File

@ -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]}) ->
<<Str:Len/binary, _/binary>> = << <<W:256>> || {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".

42
src/aeso_constants.erl Normal file
View File

@ -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).

301
src/aeso_heap.erl Normal file
View File

@ -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 = <<Address:256, Memory/binary>>,
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: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, <<Size:256, << <<(byte_size(K)):256, K/binary,
(byte_size(V)):256, V/binary>> || {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:256>> || W <- Elems>>,
{Address,<< ElemsBin/binary, Memory/binary >>};
to_binary1([],_Address) ->
<<Nil:256>> = <<(-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],<<HMem/binary, TMem/binary>>}.
%% 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 = <<V:256, _/binary>>, 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:256/signed>> = <<V:256>>,
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) ->
<<Nil:256>> = <<(-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.

301
src/aeso_heap.erl~ Normal file
View File

@ -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 = <<Address:256, Memory/binary>>,
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: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, <<Size:256, << <<(byte_size(K)):256, K/binary,
(byte_size(V)):256, V/binary>> || {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:256>> || W <- Elems>>,
{Address,<< ElemsBin/binary, Memory/binary >>};
to_binary1([],_Address) ->
<<Nil:256>> = <<(-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],<<HMem/binary, TMem/binary>>}.
%% 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 = <<V:256, _/binary>>, 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:256/signed>> = <<V:256>>,
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) ->
<<Nil:256>> = <<(-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.

103
src/aeso_icode.erl Normal file
View File

@ -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.

68
src/aeso_icode.hrl Normal file
View File

@ -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()}).

979
src/aeso_icode_to_asm.erl Normal file
View File

@ -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]},
<<Hash:256>> = 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: <last-value> <pointer>
%% 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: <N elements> 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}.

19
src/aeso_memory.erl Normal file
View File

@ -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:256,Bin/binary>>) ->
[N|binary_to_words(Bin)];
binary_to_words(Bin) ->
binary_to_words(<<Bin/binary,0>>).

413
src/aeso_parse_lib.erl Normal file
View File

@ -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. <p>
%% <tt>infixl(Elem, Op) ::= Elem | infixl(Elem, Op) Op Elem</tt>
%% </p>
-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. <p>
%% <tt>infixr(Elem, Op) ::= Elem | Elem Op infixl(Elem, Op)</tt>
%% </p>
-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.

25
src/aeso_parse_lib.hrl Normal file
View File

@ -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]).

457
src/aeso_parser.erl Normal file
View File

@ -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))])).

441
src/aeso_pretty.erl Normal file
View File

@ -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, _, <<N:256>>}) -> 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]).

127
src/aeso_scan.erl Normal file
View File

@ -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 -> <<N:64/unit:8>>; %% signature
false -> <<N:32/unit:8>> %% address
end.

147
src/aeso_scan_lib.erl Normal file
View File

@ -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("?<A~3.10.0b>", [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}).

30
src/aeso_sophia.erl Normal file
View File

@ -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().

142
src/aeso_syntax.erl Normal file
View File

@ -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).

94
src/aeso_syntax_utils.erl Normal file
View File

@ -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().

68
src/aeso_utils.erl Normal file
View File

@ -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 ]).

18
src/aesophia.app.src Normal file
View File

@ -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, []}
]}.

88
test/aeso_abi_tests.erl Normal file
View File

@ -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) ->
<<W:256>>;
from_word(S) when is_list(S) ->
Len = length(S),
Bin = <<(list_to_binary(S))/binary, 0:(32 - Len)/unit:8>>,
<<Len:256, Bin/binary>>.
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.

136
test/aeso_compiler_tests.erl Normal file
View File

@ -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"]}
].

20
test/aeso_eunit_SUITE.erl Normal file
View File

@ -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).

111
test/aeso_parser_tests.erl Normal file
View File

@ -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).

84
test/aeso_scan_tests.erl Normal file
View File

@ -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, _, <<N:256>>}) -> fmt("#~.16b", N);
show_token({comment, _, S}) -> S;
show_token({_, _, _}) -> "TODO".

160
test/aeso_test_utils.erl Normal file
View File

@ -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(<<N:256, W:32/binary, Rest/binary>>, Acc) when N < 32 ->
NotN = (32 - N) * 8,
case W of
<<S:N/binary, 0:NotN>> ->
Str = binary_to_list(S),
case lists:member(0, Str) of
true -> dump_words(<<W/binary, Rest/binary>>, [N | Acc]); %% Not a string
false -> dump_words(Rest, [binary_to_list(S), N | Acc])
end;
_ -> dump_words(<<W/binary, Rest/binary>>, [N | Acc])
end;
dump_words(<<N:256/signed, Rest/binary>>, 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.

28
test/contract_tests.erl Normal file
View File

@ -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"
%% }].

77
test/contracts/05_greeter.aes Normal file
View File

@ -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

15
test/contracts/Makefile Normal file
View File

@ -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

31
test/contracts/abort_test.aes Normal file
View File

@ -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

27
test/contracts/abort_test_int.aes Normal file
View File

@ -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)

55
test/contracts/aens.aes Normal file
View File

@ -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)

145
test/contracts/aeproof.aes Normal file
View File

@ -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")

51
test/contracts/all_syntax.aes Normal file
View File

@ -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 = '"'

12
test/contracts/builtin_bug.aes Normal file
View File

@ -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] } )

12
test/contracts/builtin_map_get_bug.aes Normal file
View File

@ -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

13
test/contracts/chain.aes Normal file
View File

@ -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})

8
test/contracts/channel_env.aes Normal file
View File

@ -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

7
test/contracts/channel_on_chain_contract_name_resolution.aes Normal file
View File

@ -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

48
test/contracts/channel_on_chain_contract_oracle.aes Normal file
View File

@ -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"

9
test/contracts/channel_remote_on_chain_contract_name_resolution.aes Normal file
View File

@ -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)

51
test/contracts/chess.aes Normal file
View File

@ -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))

86
test/contracts/complex_types.aes Normal file
View File

@ -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)

20
test/contracts/contract_types.aes Normal file
View File

@ -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)

9
test/contracts/counter.aes Normal file
View File

@ -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 })

43
test/contracts/dutch_auction.aes Normal file
View File

@ -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})

69
test/contracts/environment.aes Normal file
View File

@ -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

90
test/contracts/erc20_token.aes Normal file
View File

@ -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

22
test/contracts/events.aes Normal file
View File

@ -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)

6
test/contracts/exploits.aes Normal file
View File

@ -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)

17
test/contracts/factorial.aes Normal file
View File

@ -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)

65
test/contracts/fundme.aes Normal file
View File

@ -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) })

3
test/contracts/identity.aes Normal file
View File

@ -0,0 +1,3 @@
contract Identity =
function main (x:int) = x

9
test/contracts/init_error.aes Normal file
View File

@ -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)}

36
test/contracts/map_of_maps.aes Normal file
View File

@ -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

100
test/contracts/maps.aes Normal file
View File

@ -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) })

29
test/contracts/maps_benchmark.aes Normal file
View File

@ -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

6
test/contracts/minimal_init.aes Normal file
View File

@ -0,0 +1,6 @@
contract MinimalInit =
record state = {foo : int}
function init() =
{ foo = 0 }

123
test/contracts/multi_sig.aes Normal file
View File

@ -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... */

7
test/contracts/multiplication_server.aes Normal file
View File

@ -0,0 +1,7 @@
contract MultiplicationServer =
function multiply(x : int, y : int) =
switch(Call.value >= 100)
true => x * y

16
test/contracts/name_clash.aes Normal file
View File

@ -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

44
test/contracts/operators.aes Normal file
View File

@ -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)

112
test/contracts/oracles.aes Normal file
View File

@ -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)

11
test/contracts/oracles_err.aes Normal file
View File

@ -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.

24
test/contracts/oracles_gas.aes Normal file
View File

@ -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)

37
test/contracts/oracles_no_vm.aes Normal file
View File

@ -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)

16
test/contracts/polymorphism_test.aes Normal file
View File

@ -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])

57
test/contracts/primitive_map.aes Normal file
View File

@ -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"]

60
test/contracts/reason/rte.re Normal file
View File

@ -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;
};

126
test/contracts/reason/voting.re Normal file
View File

@ -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);
}

42
test/contracts/reason/voting_test.re Normal file
View File

@ -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();

27
test/contracts/remote_call.aes Normal file
View File

@ -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

20
test/contracts/remote_gas_test.aes Normal file
View File

@ -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

99
test/contracts/remote_oracles.aes Normal file
View File

@ -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)

23
test/contracts/remote_state.aes Normal file
View File

@ -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} }

22
test/contracts/remote_type_check.aes Normal file
View File

@ -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)

21
test/contracts/remote_value_on_err.aes Normal file
View File

@ -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)

3
test/contracts/simple.aes Normal file
View File

@ -0,0 +1,3 @@
contract Simple =
type t = int => int

29
test/contracts/simple_storage.aes Normal file
View File

@ -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})

26
test/contracts/spend_test.aes Normal file
View File

@ -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)

29
test/contracts/stack.aes Normal file
View File

@ -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

67
test/contracts/state_handling.aes Normal file
View File

@ -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} }

4
test/contracts/strings.aes Normal file
View File

@ -0,0 +1,4 @@
contract Strings =
function str_len(s) = String.length(s)
function str_concat(s1, s2) = String.concat(s1, s2)

101
test/contracts/test.aes Normal file
View File

@ -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)

42
test/contracts/type_errors.aes Normal file
View File

@ -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)

6
test/contracts/upfront_charges.aes Normal file
View File

@ -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)

7
test/contracts/value_on_err.aes Normal file
View File

@ -0,0 +1,7 @@
contract ValueOnErr =
public function err() : int =
switch(0) 1 => 5
public function ok() : int =
11

29
test/contracts/variant_types.aes Normal file
View File

@ -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

97
test/contracts/voting.aes Normal file
View File

@ -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)

56
test/contracts/withdrawal.aes Normal file
View File

@ -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) }