aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--bootstrap/lib/compiler/ebin/beam_bsm.beambin12508 -> 12740 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/beam_dead.beambin12264 -> 12156 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/beam_dict.beambin5364 -> 5300 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/beam_jump.beambin9384 -> 9444 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/beam_type.beambin14688 -> 14692 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/cerl_sets.beambin0 -> 2868 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/compiler.app1
-rw-r--r--bootstrap/lib/compiler/ebin/sys_core_fold.beambin49960 -> 49924 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/v3_codegen.beambin56796 -> 56912 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/v3_kernel.beambin47316 -> 47352 bytes
-rw-r--r--bootstrap/lib/kernel/ebin/application_controller.beambin32132 -> 32152 bytes
-rw-r--r--bootstrap/lib/kernel/ebin/code.beambin7156 -> 7156 bytes
-rw-r--r--bootstrap/lib/kernel/ebin/inet_dns.beambin19808 -> 19780 bytes
-rw-r--r--bootstrap/lib/kernel/ebin/inet_parse.beambin12904 -> 12940 bytes
-rw-r--r--bootstrap/lib/kernel/ebin/user_drv.beambin11356 -> 11428 bytes
-rw-r--r--bootstrap/lib/stdlib/ebin/erl_anno.beambin5008 -> 4900 bytes
-rw-r--r--bootstrap/lib/stdlib/ebin/erl_lint.beambin89464 -> 89828 bytes
-rw-r--r--erts/doc/src/erlang.xml358
-rw-r--r--erts/emulator/beam/erl_alloc_util.c61
-rw-r--r--erts/emulator/beam/erl_node_tables.c4
-rw-r--r--erts/emulator/beam/erl_process.c151
-rw-r--r--erts/emulator/test/monitor_SUITE.erl172
-rw-r--r--erts/etc/ose/run_erl.c2
-rw-r--r--lib/.gitignore2
-rw-r--r--lib/asn1/doc/src/asn1ct.xml18
-rw-r--r--lib/asn1/vsn.mk2
-rw-r--r--lib/compiler/src/Makefile1
-rw-r--r--lib/compiler/src/beam_dead.erl27
-rw-r--r--lib/compiler/src/beam_dict.erl78
-rw-r--r--lib/compiler/src/beam_jump.erl44
-rw-r--r--lib/compiler/src/beam_type.erl8
-rw-r--r--lib/compiler/src/cerl_sets.erl206
-rw-r--r--lib/compiler/src/compiler.app.src1
-rw-r--r--lib/compiler/src/sys_core_fold.erl92
-rw-r--r--lib/compiler/src/v3_codegen.erl57
-rw-r--r--lib/compiler/src/v3_kernel.erl12
-rw-r--r--lib/compiler/src/v3_life.erl17
-rw-r--r--lib/compiler/vsn.mk2
-rw-r--r--lib/cosNotification/src/cosNotification.app.src2
-rw-r--r--lib/crypto/test/crypto_SUITE.erl5
-rw-r--r--lib/crypto/test/old_crypto_SUITE.erl6
-rw-r--r--lib/crypto/vsn.mk2
-rw-r--r--lib/debugger/src/debugger.app.src4
-rw-r--r--lib/debugger/test/map_SUITE.erl4
-rw-r--r--lib/debugger/vsn.mk2
-rw-r--r--lib/dialyzer/src/dialyzer.app.src4
-rw-r--r--lib/dialyzer/vsn.mk2
-rw-r--r--lib/edoc/src/edoc.app.src2
-rw-r--r--lib/edoc/vsn.mk2
-rw-r--r--lib/erl_docgen/src/erl_docgen.app.src2
-rw-r--r--lib/eunit/src/eunit.app.src2
-rw-r--r--lib/eunit/vsn.mk2
-rw-r--r--lib/hipe/main/hipe.app.src4
-rw-r--r--lib/hipe/vsn.mk2
-rw-r--r--lib/inets/src/http_client/httpc_handler.erl6
-rw-r--r--lib/inets/vsn.mk4
-rw-r--r--lib/kernel/src/code.erl9
-rw-r--r--lib/kernel/src/inet_parse.erl30
-rw-r--r--lib/kernel/src/kernel.appup.src6
-rw-r--r--lib/kernel/src/user_drv.erl48
-rw-r--r--lib/kernel/test/inet_SUITE.erl3
-rw-r--r--lib/kernel/vsn.mk2
-rw-r--r--lib/megaco/src/app/megaco.app.src4
-rw-r--r--lib/megaco/src/app/megaco.appup.src7
-rw-r--r--lib/megaco/vsn.mk4
-rw-r--r--lib/mnesia/vsn.mk2
-rw-r--r--lib/observer/vsn.mk2
-rw-r--r--lib/os_mon/vsn.mk2
-rw-r--r--lib/parsetools/src/parsetools.app.src2
-rw-r--r--lib/parsetools/vsn.mk2
-rw-r--r--lib/sasl/vsn.mk2
-rw-r--r--lib/snmp/src/app/snmp.app.src4
-rw-r--r--lib/snmp/src/app/snmp.appup.src4
-rw-r--r--lib/snmp/vsn.mk2
-rw-r--r--lib/ssh/doc/src/ssh.xml102
-rw-r--r--lib/ssh/src/ssh.erl148
-rw-r--r--lib/ssh/src/ssh_auth.erl66
-rw-r--r--lib/ssh/src/ssh_auth.hrl2
-rw-r--r--lib/ssh/src/ssh_connection_handler.erl70
-rw-r--r--lib/ssh/src/ssh_transport.erl132
-rw-r--r--lib/ssh/test/ssh_basic_SUITE.erl60
-rw-r--r--lib/ssh/test/ssh_connection_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_sftp_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_sftpd_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl1
-rw-r--r--lib/ssh/test/ssh_to_openssh_SUITE.erl10
-rw-r--r--lib/ssh/test/ssh_unicode_SUITE.erl1
-rw-r--r--lib/stdlib/src/erl_anno.erl4
-rw-r--r--lib/stdlib/src/erl_lint.erl63
-rw-r--r--lib/stdlib/src/stdlib.appup.src8
-rw-r--r--lib/stdlib/src/zip.erl2
-rw-r--r--lib/stdlib/test/binary_module_SUITE.erl50
-rw-r--r--lib/stdlib/test/erl_anno_SUITE.erl1
-rw-r--r--lib/stdlib/test/ets_SUITE.erl14
-rw-r--r--lib/stdlib/test/io_proto_SUITE.erl2
-rw-r--r--lib/stdlib/test/rand_SUITE.erl2
-rw-r--r--lib/stdlib/test/unicode_SUITE.erl3
-rw-r--r--lib/stdlib/vsn.mk2
-rw-r--r--lib/syntax_tools/doc/overview.edoc83
-rw-r--r--lib/syntax_tools/doc/src/Makefile2
-rw-r--r--lib/syntax_tools/doc/src/ref_man.xml13
-rw-r--r--lib/syntax_tools/examples/merl/Makefile22
-rw-r--r--lib/syntax_tools/examples/merl/basic.erl77
-rw-r--r--lib/syntax_tools/examples/merl/basic_test.erl77
-rw-r--r--lib/syntax_tools/examples/merl/basicc.erl149
-rw-r--r--lib/syntax_tools/examples/merl/lisp.erl160
-rw-r--r--lib/syntax_tools/examples/merl/lisp_test.erl98
-rw-r--r--lib/syntax_tools/examples/merl/lispc.erl102
-rw-r--r--lib/syntax_tools/examples/merl/merl_build.erl104
-rw-r--r--lib/syntax_tools/include/merl.hrl29
-rw-r--r--lib/syntax_tools/src/Makefile21
-rw-r--r--lib/syntax_tools/src/merl.erl1230
-rw-r--r--lib/syntax_tools/src/merl_tests.erl539
-rw-r--r--lib/syntax_tools/src/merl_transform.erl262
-rw-r--r--lib/syntax_tools/src/syntax_tools.app.src4
-rw-r--r--lib/syntax_tools/test/Makefile3
-rw-r--r--lib/syntax_tools/test/merl_SUITE.erl91
-rw-r--r--lib/syntax_tools/vsn.mk2
-rw-r--r--lib/tools/src/tools.app.src4
-rw-r--r--lib/tools/test/lcnt_SUITE.erl10
-rw-r--r--lib/tools/vsn.mk2
-rw-r--r--lib/typer/vsn.mk2
-rw-r--r--lib/wx/vsn.mk2
-rw-r--r--lib/xmerl/src/xmerl.app.src2
124 files changed, 4428 insertions, 916 deletions
diff --git a/bootstrap/lib/compiler/ebin/beam_bsm.beam b/bootstrap/lib/compiler/ebin/beam_bsm.beam
index 6fc683bf76..a6757dfcfb 100644
--- a/bootstrap/lib/compiler/ebin/beam_bsm.beam
+++ b/bootstrap/lib/compiler/ebin/beam_bsm.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/beam_dead.beam b/bootstrap/lib/compiler/ebin/beam_dead.beam
index 0bd9767208..6ae6de1d8b 100644
--- a/bootstrap/lib/compiler/ebin/beam_dead.beam
+++ b/bootstrap/lib/compiler/ebin/beam_dead.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/beam_dict.beam b/bootstrap/lib/compiler/ebin/beam_dict.beam
index ccab57cc81..17b3c40eda 100644
--- a/bootstrap/lib/compiler/ebin/beam_dict.beam
+++ b/bootstrap/lib/compiler/ebin/beam_dict.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/beam_jump.beam b/bootstrap/lib/compiler/ebin/beam_jump.beam
index 136036ae39..8dd6375403 100644
--- a/bootstrap/lib/compiler/ebin/beam_jump.beam
+++ b/bootstrap/lib/compiler/ebin/beam_jump.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/beam_type.beam b/bootstrap/lib/compiler/ebin/beam_type.beam
index 4094cec9e6..cb3bc1a8bd 100644
--- a/bootstrap/lib/compiler/ebin/beam_type.beam
+++ b/bootstrap/lib/compiler/ebin/beam_type.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/cerl_sets.beam b/bootstrap/lib/compiler/ebin/cerl_sets.beam
new file mode 100644
index 0000000000..d16543cdbe
--- /dev/null
+++ b/bootstrap/lib/compiler/ebin/cerl_sets.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/compiler.app b/bootstrap/lib/compiler/ebin/compiler.app
index dfe077d5b9..c9633c1369 100644
--- a/bootstrap/lib/compiler/ebin/compiler.app
+++ b/bootstrap/lib/compiler/ebin/compiler.app
@@ -45,6 +45,7 @@
cerl,
cerl_clauses,
cerl_inline,
+ cerl_sets,
cerl_trees,
compile,
core_scan,
diff --git a/bootstrap/lib/compiler/ebin/sys_core_fold.beam b/bootstrap/lib/compiler/ebin/sys_core_fold.beam
index 2ed29957b3..f97931d49c 100644
--- a/bootstrap/lib/compiler/ebin/sys_core_fold.beam
+++ b/bootstrap/lib/compiler/ebin/sys_core_fold.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/v3_codegen.beam b/bootstrap/lib/compiler/ebin/v3_codegen.beam
index 7b33f9cbff..e53f0fcd12 100644
--- a/bootstrap/lib/compiler/ebin/v3_codegen.beam
+++ b/bootstrap/lib/compiler/ebin/v3_codegen.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/v3_kernel.beam b/bootstrap/lib/compiler/ebin/v3_kernel.beam
index 5817c6ae58..f5cdbb6e40 100644
--- a/bootstrap/lib/compiler/ebin/v3_kernel.beam
+++ b/bootstrap/lib/compiler/ebin/v3_kernel.beam
Binary files differ
diff --git a/bootstrap/lib/kernel/ebin/application_controller.beam b/bootstrap/lib/kernel/ebin/application_controller.beam
index 9a7907cb38..c4fa46e33e 100644
--- a/bootstrap/lib/kernel/ebin/application_controller.beam
+++ b/bootstrap/lib/kernel/ebin/application_controller.beam
Binary files differ
diff --git a/bootstrap/lib/kernel/ebin/code.beam b/bootstrap/lib/kernel/ebin/code.beam
index 9a644b6b48..ac6cb538cd 100644
--- a/bootstrap/lib/kernel/ebin/code.beam
+++ b/bootstrap/lib/kernel/ebin/code.beam
Binary files differ
diff --git a/bootstrap/lib/kernel/ebin/inet_dns.beam b/bootstrap/lib/kernel/ebin/inet_dns.beam
index 0c5b6c73e1..1fb789ae81 100644
--- a/bootstrap/lib/kernel/ebin/inet_dns.beam
+++ b/bootstrap/lib/kernel/ebin/inet_dns.beam
Binary files differ
diff --git a/bootstrap/lib/kernel/ebin/inet_parse.beam b/bootstrap/lib/kernel/ebin/inet_parse.beam
index 6d28aa3c95..294afcea30 100644
--- a/bootstrap/lib/kernel/ebin/inet_parse.beam
+++ b/bootstrap/lib/kernel/ebin/inet_parse.beam
Binary files differ
diff --git a/bootstrap/lib/kernel/ebin/user_drv.beam b/bootstrap/lib/kernel/ebin/user_drv.beam
index 54cf78d6ce..726a130b55 100644
--- a/bootstrap/lib/kernel/ebin/user_drv.beam
+++ b/bootstrap/lib/kernel/ebin/user_drv.beam
Binary files differ
diff --git a/bootstrap/lib/stdlib/ebin/erl_anno.beam b/bootstrap/lib/stdlib/ebin/erl_anno.beam
index a07f730e99..4807dac5f9 100644
--- a/bootstrap/lib/stdlib/ebin/erl_anno.beam
+++ b/bootstrap/lib/stdlib/ebin/erl_anno.beam
Binary files differ
diff --git a/bootstrap/lib/stdlib/ebin/erl_lint.beam b/bootstrap/lib/stdlib/ebin/erl_lint.beam
index 5a8bc2a7f1..a5722e5daa 100644
--- a/bootstrap/lib/stdlib/ebin/erl_lint.beam
+++ b/bootstrap/lib/stdlib/ebin/erl_lint.beam
Binary files differ
diff --git a/erts/doc/src/erlang.xml b/erts/doc/src/erlang.xml
index 6ca57566aa..3fea64cef5 100644
--- a/erts/doc/src/erlang.xml
+++ b/erts/doc/src/erlang.xml
@@ -539,55 +539,94 @@
<name name="cancel_timer" arity="2"/>
<fsummary>Cancel a timer</fsummary>
<desc>
- <p>Cancels a timer. <c><anno>TimerRef</anno></c> needs to refer to
- a timer that was created by either
- <seealso marker="#send_after/4"><c>erlang:send_after()</c></seealso>,
- or <seealso marker="#start_timer/4"><c>erlang:start_timer()</c></seealso>.</p>
- <p>Currently available <c><anno>Option</anno>s</c>:</p>
+ <p>
+ Cancels a timer that has been created by either
+ <seealso marker="#start_timer/4"><c>erlang:start_timer()</c></seealso>,
+ or <seealso marker="#send_after/4"><c>erlang:send_after()</c></seealso>.
+ <c><anno>TimerRef</anno></c> identifies the timer, and
+ was returned by the BIF that created the timer.
+ </p>
+ <p>Currently available <c><anno>Option</anno></c>s:</p>
<taglist>
<tag><c>{async, Async}</c></tag>
<item>
- <p>Asynchronous request for cancellation. <c>Async</c>
- defaults to <c>false</c>. That is the operation will be
- performed synchronously. When <c>Async</c> is set to
- <c>true</c> the cancel operation will be performed
- asynchronously. That is, <c>cancel_timer()</c> will send
- a request for cancellation to the timer service that
- manages the timer, and then return <c>ok</c>.</p></item>
+ <p>
+ Asynchronous request for cancellation. <c>Async</c>
+ defaults to <c>false</c> which will cause the
+ cancellation to be performed synchronously. When
+ <c>Async</c> is set to <c>true</c>, the cancel
+ operation will be performed asynchronously. That is,
+ <c>erlang:cancel_timer()</c> will send an asynchronous
+ request for cancellation to the timer service that
+ manages the timer, and then return <c>ok</c>.
+ </p>
+ </item>
<tag><c>{info, Info}</c></tag>
<item>
- <p>Request information about the <c>Result</c> of the
- cancellation. <c>Info</c> defaults to <c>true</c>. That
- is information will be given. When <c>Info</c> is set to
- <c>false</c> no information about the result of the cancel
- operation will be given. When the operation is performed
- synchronously the <c>Result</c> will returned from
- <c>cancel_timer()</c>. When the operation is performed
- asynchronously, a message on the form
- <c>{cancel_timer, <anno>TimerRef</anno>, <anno>Result</anno>}</c>
- will be sent to the caller of <c>cancel_timer()</c> when
- the operation has been performed.</p></item>
+ <p>
+ Request information about the <c><anno>Result</anno></c>
+ of the cancellation. <c>Info</c> defaults to <c>true</c>
+ which means that the <c><anno>Result</anno></c> will
+ be given. When <c>Info</c> is set to <c>false</c>, no
+ information about the result of the cancellation
+ will be given. When the operation is performed</p>
+ <taglist>
+ <tag>synchronously</tag>
+ <item>
+ <p>
+ If <c>Info</c> is <c>true</c>, the <c>Result</c> will
+ returned by <c>erlang:cancel_timer()</c>; otherwise,
+ <c>ok</c> will be returned.
+ </p>
+ </item>
+ <tag>asynchronously</tag>
+ <item>
+ <p>
+ If <c>Info</c> is <c>true</c>, a message on the form
+ <c>{cancel_timer, <anno>TimerRef</anno>,
+ <anno>Result</anno>}</c> will be sent to the
+ caller of <c>erlang:cancel_timer()</c> when the
+ cancellation operation has been performed; otherwise,
+ no message will be sent.
+ </p>
+ </item>
+ </taglist>
+ </item>
</taglist>
- <p>When the <c><anno>Result</anno></c> equals <c>false</c> a timer
- corresponding to <c><anno>TimerRef</anno></c> could not be found. This
- can be either because the timer had expired, been canceled, or because
- <c><anno>TimerRef</anno></c> do not correspond to a timer. When the
- <c><anno>Result</anno></c> is an integer, it represents
- the time in milli seconds left before the timer will expire.</p>
- <note><p>The timer service that manages the timer may be co-located
- with another scheduler than the scheduler that the calling process
- is executing on. In this case communication with the timer
- service will be performed using asynchronous signals. If the calling
- process is in critical path and can do other things while waiting
- for the result of this operation, you want to use the <c>{async, true}</c>
- option.</p></note>
+ <p>
+ More <c><anno>Option</anno></c>s may be added in the future.
+ </p>
+ <p>
+ When the <c><anno>Result</anno></c> equals <c>false</c>, a
+ timer corresponding to <c><anno>TimerRef</anno></c> could not
+ be found. This can be either because the timer had expired,
+ already had been canceled, or because <c><anno>TimerRef</anno></c>
+ never has corresponded to a timer. If the timer has expired,
+ the timeout message has been sent, but it does not tell you
+ whether or not it has arrived at its destination yet. When the
+ <c><anno>Result</anno></c> is an integer, it represents the
+ time in milli-seconds left until the timer will expire.
+ </p>
+ <note>
+ <p>
+ The timer service that manages the timer may be co-located
+ with another scheduler than the scheduler that the calling
+ process is executing on. If this is the case, communication
+ with the timer service will take much longer time than if it
+ is located locally. If the calling process is in critical
+ path, and can do other things while waiting for the result
+ of this operation, or is not interested in the result of
+ the operation, you want to use the <c>{async, true}</c>
+ option. If using the <c>{async, false}</c> option, the calling
+ process will be blocked until the operation has been
+ performed.
+ </p>
+ </note>
<p>See also
<seealso marker="#send_after/4"><c>erlang:send_after/4</c></seealso>,
<seealso marker="#start_timer/4"><c>erlang:start_timer/4</c></seealso>,
and
<seealso marker="#read_timer/2"><c>erlang:read_timer/2</c></seealso>.</p>
- <p>Note: Cancelling a timer does not guarantee that the message
- has not already been delivered to the message queue.</p>
</desc>
</func>
<func>
@@ -596,7 +635,7 @@
<desc>
<p>Cancels a timer. The same as calling
<seealso marker="#cancel_timer/2"><c>erlang:cancel_timer(TimerRef,
- [{async, false}, {info, true}])</c></seealso>.</p>
+ [])</c></seealso>.</p>
</desc>
</func>
<func>
@@ -4548,37 +4587,60 @@ os_prompt% </pre>
<name name="read_timer" arity="2"/>
<fsummary>Read the state of a timer</fsummary>
<desc>
- <p>Read the state of a timer. <c><anno>TimerRef</anno></c>
- needs to refer to a timer that was created by either
- <seealso marker="#send_after/4"><c>erlang:send_after()</c></seealso>,
- or <seealso marker="#start_timer/4"><c>erlang:start_timer()</c></seealso>.</p>
+ <p>
+ Read the state of a timer that has been created by either
+ <seealso marker="#start_timer/4"><c>erlang:start_timer()</c></seealso>,
+ or <seealso marker="#send_after/4"><c>erlang:send_after()</c></seealso>.
+ <c><anno>TimerRef</anno></c> identifies the timer, and
+ was returned by the BIF that created the timer.
+ </p>
<p>Currently available <c><anno>Option</anno>s</c>:</p>
<taglist>
<tag><c>{async, Async}</c></tag>
<item>
- <p>Asynchronous request. <c>Async</c> defaults to <c>false</c>. That
- is the operation will be performed synchronously, and the <c>Result</c>
- will returned from <c>read_timer()</c>. When <c>Async</c> is set to
- <c>true</c>, <c>read_timer()</c> will send a request for the
- <c>Result</c> to a timer service that manages the timer and then
- return <c>ok</c>. A message on the format
- <c>{read_timer, <anno>TimerRef</anno>, <anno>Result</anno>}</c>
- will be sent to the caller of <c>read_timer()</c> when
- the operation has been processed.</p></item>
+ <p>
+ Asynchronous request for state information. <c>Async</c>
+ defaults to <c>false</c> which will cause the operation
+ to be performed synchronously. In this case, the <c>Result</c>
+ will be returned by <c>erlang:read_timer()</c>. When
+ <c>Async</c> is set to <c>true</c>, <c>erlang:read_timer()</c>
+ will send an asynchronous request for the state information
+ to the timer service that manages the timer, and then return
+ <c>ok</c>. A message on the format <c>{read_timer,
+ <anno>TimerRef</anno>, <anno>Result</anno>}</c> will be
+ sent to the caller of <c>erlang:read_timer()</c> when the
+ operation has been processed.
+ </p>
+ </item>
</taglist>
- <p>When the <c><anno>Result</anno></c> equals <c>false</c> a timer
- corresponding to <c><anno>TimerRef</anno></c> could not be found. This
- can be either because the timer had expired, been canceled, or because
- <c><anno>TimerRef</anno></c> do not correspond to a timer. When the
- <c><anno>Result</anno></c> is an integer, it represents
- the time in milli seconds left before the timer will expire.</p>
- <note><p>The timer service that manages the timer may be co-located
- with another scheduler than the scheduler that the calling process
- is executing on. In this case communication with the timer
- service will be performed using asynchronous signals. If the calling
- process is in critical path and can do other things while waiting
- for the result of this operation, you want to use the <c>{async, true}</c>
- option.</p></note>
+ <p>
+ More <c><anno>Option</anno></c>s may be added in the future.
+ </p>
+ <p>
+ When the <c><anno>Result</anno></c> equals <c>false</c>, a
+ timer corresponding to <c><anno>TimerRef</anno></c> could not
+ be found. This can be either because the timer had expired,
+ had been canceled, or because <c><anno>TimerRef</anno></c>
+ never has corresponded to a timer. If the timer has expired,
+ the timeout message has been sent, but it does not tell you
+ whether or not it has arrived at its destination yet. When the
+ <c><anno>Result</anno></c> is an integer, it represents the
+ time in milli-seconds left until the timer will expire.
+ </p>
+ <note>
+ <p>
+ The timer service that manages the timer may be co-located
+ with another scheduler than the scheduler that the calling
+ process is executing on. If this is the case, communication
+ with the timer service will take much longer time than if it
+ is located locally. If the calling process is in critical
+ path, and can do other things while waiting for the result
+ of this operation you want to use the <c>{async, true}</c>
+ option. If using the <c>{async, false}</c> option, the calling
+ process will be blocked until the operation has been
+ performed.
+ </p>
+ </note>
<p>See also
<seealso marker="#send_after/4"><c>erlang:send_after/4</c></seealso>,
<seealso marker="#start_timer/4"><c>erlang:start_timer/4</c></seealso>,
@@ -4592,7 +4654,7 @@ os_prompt% </pre>
<desc>
<p>Read the state of a timer. The same as calling
<seealso marker="#read_timer/2"><c>erlang:read_timer(TimerRef,
- [{async, false}])</c></seealso>.</p>
+ [])</c></seealso>.</p>
</desc>
</func>
<func>
@@ -4744,48 +4806,14 @@ true</pre>
<name name="send_after" arity="4"/>
<fsummary>Start a timer</fsummary>
<desc>
- <p>Starts a timer. When the timer expires, the message
- <c><anno>Msg</anno></c> will be sent to
- <c><anno>Dest</anno></c>.</p>
- <p>If <c><anno>Dest</anno></c> is a <c>pid()</c> it has to
- be a <c>pid()</c> of a local process, dead or alive.</p>
- <p>Currently available <c><anno>Option</anno>s</c>:</p>
- <taglist>
- <tag><c>{abs, Abs}</c></tag>
- <item>
- <p>Absolute timeout. When <c>Abs</c> is <c>false</c>
- the <c><anno>Time</anno></c> value will be interpreted
- as a time in milli-seconds relative current
- <seealso marker="time_correction#Erlang_Monotonic_Time">Erlang
- monotonic time</seealso>. When <c>Abs</c> is <c>true</c> the
- <c><anno>Time</anno></c> value will be interpreted as an absolute
- Erlang monotonic time of milli second time unit. <c>Abs</c>
- defaults to <c>false</c>.</p>
- </item>
- </taglist>
- <p>The absolute time when the timer is set to expire needs
- to be in the range between
- <seealso marker="#system_info_start_time"><c>erlang:system_info(start_time)</c></seealso>
- and
- <seealso marker="#system_info_end_time"><c>erlang:system_info(end_time)</c></seealso>.
- If a negative relative time is specified the time is not
- allowed to be negative.</p>
- <p>If <c><anno>Dest</anno></c> is an <c>atom()</c>, it is supposed to be the name of
- a registered process. The process referred to by the name is
- looked up at the time of delivery. No error is given if
- the name does not refer to a process.</p>
- <p>If <c><anno>Dest</anno></c> is a <c>pid()</c>, the timer will be automatically
- canceled if the process referred to by the <c>pid()</c> is not alive,
- or when the process exits. This feature was introduced in
- erts version 5.4.11. Note that timers will not be
- automatically canceled when <c><anno>Dest</anno></c> is an <c>atom()</c>.</p>
- <p>See also
- <seealso marker="#start_timer/4"><c>erlang:send_timer/4</c></seealso>,
- <seealso marker="#cancel_timer/2"><c>erlang:cancel_timer/2</c></seealso>,
- and
- <seealso marker="#read_timer/2"><c>erlang:read_timer/2</c></seealso>.</p>
- <p>Failure: <c>badarg</c> if the arguments does not satisfy
- the requirements specified above.</p>
+ <p>
+ Starts a timer. When the timer expires, the message
+ <c><anno>Msg</anno></c> will be sent to the process
+ identified by <c><anno>Dest</anno></c>. Appart from
+ the format of the message sent to
+ <c><anno>Dest</anno></c> when the timer expires
+ <c>erlang:send_after/4</c> works exactly as
+ <seealso marker="#start_timer/4"><c>erlang:start_timer/4</c></seealso>.</p>
</desc>
</func>
<func>
@@ -4793,36 +4821,8 @@ true</pre>
<fsummary>Start a timer</fsummary>
<desc>
<p>Starts a timer. The same as calling
- <seealso marker="#send_timer/4"><c>erlang:send_after(<anno>Time</anno>,
- <anno>Dest</anno>, <anno>Msg</anno>, [{abs, false}])</c></seealso>.</p>
- </desc>
- </func>
- <func>
- <name name="send_after" arity="3"/>
- <type_desc variable="Time">0 &lt;= Time &lt;= 4294967295</type_desc>
- <fsummary>Start a timer</fsummary>
- <desc>
- <p>Starts a timer which will send the message <c>Msg</c>
- to <c><anno>Dest</anno></c> after <c><anno>Time</anno></c> milliseconds.</p>
- <p>If <c><anno>Dest</anno></c> is a <c>pid()</c> it has to be a <c>pid()</c> of a local process, dead or alive.</p>
- <p>The <c><anno>Time</anno></c> value can, in the current implementation, not be greater than 4294967295.</p>
- <p>If <c><anno>Dest</anno></c> is an <c>atom()</c>, it is supposed to be the name of
- a registered process. The process referred to by the name is
- looked up at the time of delivery. No error is given if
- the name does not refer to a process.</p>
-
- <p>If <c><anno>Dest</anno></c> is a <c>pid()</c>, the timer will be automatically
- canceled if the process referred to by the <c>pid()</c> is not alive,
- or when the process exits. This feature was introduced in
- erts version 5.4.11. Note that timers will not be
- automatically canceled when <c><anno>Dest</anno></c> is an <c>atom</c>.</p>
- <p>See also
- <seealso marker="#start_timer/3">erlang:start_timer/3</seealso>,
- <seealso marker="#cancel_timer/2">erlang:cancel_timer/2</seealso>,
- and
- <seealso marker="#read_timer/2">erlang:read_timer/2</seealso>.</p>
- <p>Failure: <c>badarg</c> if the arguments does not satisfy
- the requirements specified above.</p>
+ <seealso marker="#send_after/4"><c>erlang:send_after(<anno>Time</anno>,
+ <anno>Dest</anno>, <anno>Msg</anno>, [])</c></seealso>.</p>
</desc>
</func>
<func>
@@ -5231,41 +5231,59 @@ true</pre>
<name name="start_timer" arity="4"/>
<fsummary>Start a timer</fsummary>
<desc>
- <p>Starts a timer. When the timer expires, the message
+ <p>
+ Starts a timer. When the timer expires, the message
<c>{timeout, <anno>TimerRef</anno>, <anno>Msg</anno>}</c>
- will be sent to <c><anno>Dest</anno></c>.</p>
- <p>If <c><anno>Dest</anno></c> is a <c>pid()</c> it has to
- be a <c>pid()</c> of a local process, dead or alive.</p>
- <p>Currently available <c><anno>Option</anno>s</c>:</p>
+ will be sent to the process identified by
+ <c><anno>Dest</anno></c>.
+ </p>
+ <p>Currently available <c><anno>Option</anno></c>s:</p>
<taglist>
<tag><c>{abs, Abs}</c></tag>
<item>
- <p>Absolute timeout. When <c>Abs</c> is <c>false</c>
- the <c><anno>Time</anno></c> value will be interpreted
- as a time in milli-seconds relative current
- <seealso marker="time_correction#Erlang_Monotonic_Time">Erlang
- monotonic time</seealso>. When <c>Abs</c> is <c>true</c> the
- <c><anno>Time</anno></c> value will be interpreted as an absolute
- Erlang monotonic time of milli second time unit. <c>Abs</c>
- defaults to <c>false</c>.</p>
+ <p>
+ Absolute <c><anno>Time</anno></c> value. <c>Abs</c>
+ defaults to <c>false</c> which means that the
+ <c><anno>Time</anno></c> value will be interpreted
+ as a time in milli-seconds relative current
+ <seealso marker="time_correction#Erlang_Monotonic_Time">Erlang
+ monotonic time</seealso>. When <c>Abs</c> is set to
+ <c>true</c>, the <c><anno>Time</anno></c> value will
+ be interpreted as an absolute Erlang monotonic time of
+ milli-seconds
+ <seealso marker="#type_time_unit">time unit</seealso>.
+ </p>
</item>
</taglist>
- <p>The absolute time when the timer is set to expire needs
- to be in the range between
- <seealso marker="#system_info_start_time"><c>erlang:system_info(start_time)</c></seealso>
- and
- <seealso marker="#system_info_end_time"><c>erlang:system_info(end_time)</c></seealso>.
- If a negative relative time is specified the time is not
- allowed to be negative.</p>
- <p>If <c><anno>Dest</anno></c> is an <c>atom()</c>, it is supposed to be the name of
- a registered process. The process referred to by the name is
- looked up at the time of delivery. No error is given if
- the name does not refer to a process.</p>
- <p>If <c><anno>Dest</anno></c> is a <c>pid()</c>, the timer will be automatically
- canceled if the process referred to by the <c>pid()</c> is not alive,
- or when the process exits. This feature was introduced in
- erts version 5.4.11. Note that timers will not be
- automatically canceled when <c><anno>Dest</anno></c> is an <c>atom()</c>.</p>
+ <p>
+ More <c><anno>Option</anno></c>s may be added in the future.
+ </p>
+ <p>
+ The absolute point in time that the timer is set to expire on
+ has to be in the interval
+ <c>[</c><seealso marker="#system_info_start_time"><c>erlang:system_info(start_time)</c></seealso><c>,
+ </c><seealso marker="#system_info_end_time"><c>erlang:system_info(end_time)</c></seealso><c>]</c>.
+ Further, if a relative time is specified, the <c><anno>Time</anno></c> value
+ is not allowed to be negative.
+ </p>
+ <p>
+ If <c><anno>Dest</anno></c> is a <c>pid()</c>, it has to
+ be a <c>pid()</c> of a process created on the current
+ runtime system instance. This process may or may not
+ have terminated. If <c><anno>Dest</anno></c> is an
+ <c>atom()</c>, it will be interpreted as the name of a
+ locally registered process. The process referred to by the
+ name is looked up at the time of timer expiration. No error
+ is given if the name does not refer to a process.
+ </p>
+ <p>
+ If <c><anno>Dest</anno></c> is a <c>pid()</c>, the timer will
+ be automatically canceled if the process referred to by the
+ <c>pid()</c> is not alive, or when the process exits. This
+ feature was introduced in erts version 5.4.11. Note that
+ timers will not be automatically canceled when
+ <c><anno>Dest</anno></c> is an <c>atom()</c>.
+ </p>
<p>See also
<seealso marker="#send_after/4"><c>erlang:send_after/4</c></seealso>,
<seealso marker="#cancel_timer/2"><c>erlang:cancel_timer/2</c></seealso>,
@@ -5281,7 +5299,7 @@ true</pre>
<desc>
<p>Starts a timer. The same as calling
<seealso marker="#start_timer/4"><c>erlang:start_timer(<anno>Time</anno>,
- <anno>Dest</anno>, <anno>Msg</anno>, [{abs, false}])</c></seealso>.</p>
+ <anno>Dest</anno>, <anno>Msg</anno>, [])</c></seealso>.</p>
</desc>
</func>
<func>
@@ -6845,7 +6863,9 @@ ok
<item><p>The <seealso marker="#monotonic_time/0">Erlang monotonic
time</seealso> in <c>native</c>
<seealso marker="#type_time_unit">time unit</seealso> at the
- time when current Erlang runtime system instance started.</p></item>
+ time when current Erlang runtime system instance started. See also
+ <seealso marker="#system_info_end_time"><c>erlang:system_info(end_time)</c></seealso>.
+ </p></item>
<tag><c>system_version</c></tag>
<item>
<p>Returns a string containing version number and
diff --git a/erts/emulator/beam/erl_alloc_util.c b/erts/emulator/beam/erl_alloc_util.c
index 2f277690e4..b92533f228 100644
--- a/erts/emulator/beam/erl_alloc_util.c
+++ b/erts/emulator/beam/erl_alloc_util.c
@@ -718,7 +718,7 @@ static void make_name_atoms(Allctr_t *allctr);
static Block_t *create_carrier(Allctr_t *, Uint, UWord);
static void destroy_carrier(Allctr_t *, Block_t *, Carrier_t **);
static void mbc_free(Allctr_t *allctr, void *p, Carrier_t **busy_pcrr_pp);
-static void dealloc_block(Allctr_t *, void *, int);
+static void dealloc_block(Allctr_t *, void *, ErtsAlcFixList_t *, int);
/* internal data... */
@@ -1067,17 +1067,21 @@ typedef struct {
} ErtsAllctrFixDDBlock_t;
#endif
+#define ERTS_ALC_FIX_NO_UNUSE (((ErtsAlcType_t) 1) << ERTS_ALC_N_BITS)
+
static ERTS_INLINE void
dealloc_fix_block(Allctr_t *allctr,
ErtsAlcType_t type,
void *ptr,
+ ErtsAlcFixList_t *fix,
int dec_cc_on_redirect)
{
#ifdef ERTS_SMP
/* May be redirected... */
- ((ErtsAllctrFixDDBlock_t *) ptr)->fix_type = type;
+ ASSERT((type & ERTS_ALC_FIX_NO_UNUSE) == 0);
+ ((ErtsAllctrFixDDBlock_t *) ptr)->fix_type = type | ERTS_ALC_FIX_NO_UNUSE;
#endif
- dealloc_block(allctr, ptr, dec_cc_on_redirect);
+ dealloc_block(allctr, ptr, fix, dec_cc_on_redirect);
}
static ERTS_INLINE void
@@ -1123,8 +1127,7 @@ fix_cpool_check_shrink(Allctr_t *allctr,
if (fix->u.cpool.min_list_size > fix->list_size)
fix->u.cpool.min_list_size = fix->list_size;
- fix->u.cpool.allocated--;
- dealloc_fix_block(allctr, type, p, 0);
+ dealloc_fix_block(allctr, type, p, fix, 0);
}
}
}
@@ -1170,7 +1173,8 @@ static ERTS_INLINE void
fix_cpool_free(Allctr_t *allctr,
ErtsAlcType_t type,
void *p,
- Carrier_t **busy_pcrr_pp)
+ Carrier_t **busy_pcrr_pp,
+ int unuse)
{
ErtsAlcFixList_t *fix;
@@ -1178,8 +1182,9 @@ fix_cpool_free(Allctr_t *allctr,
&& type <= ERTS_ALC_N_MAX_A_FIXED_SIZE);
fix = &allctr->fix[type - ERTS_ALC_N_MIN_A_FIXED_SIZE];
-
- fix->u.cpool.used--;
+
+ if (unuse)
+ fix->u.cpool.used--;
if ((!busy_pcrr_pp || !*busy_pcrr_pp)
&& !fix->u.cpool.shrink_list
@@ -1237,8 +1242,7 @@ fix_cpool_alloc_shrink(Allctr_t *allctr, erts_aint32_t flgs)
fix->list = *((void **) ptr);
fix->list_size--;
fix->u.cpool.shrink_list--;
- fix->u.cpool.allocated--;
- dealloc_fix_block(allctr, type, ptr, 0);
+ dealloc_fix_block(allctr, type, ptr, fix, 0);
}
if (fix->u.cpool.min_list_size > fix->list_size)
fix->u.cpool.min_list_size = fix->list_size;
@@ -1399,7 +1403,7 @@ fix_nocpool_alloc_shrink(Allctr_t *allctr, erts_aint32_t flgs)
ptr = fix->list;
fix->list = *((void **) ptr);
fix->list_size--;
- dealloc_block(allctr, ptr, 0);
+ dealloc_block(allctr, ptr, NULL, 0);
fix->u.nocpool.allocated--;
}
if (fix->list_size != 0) {
@@ -1746,11 +1750,13 @@ handle_delayed_fix_dealloc(Allctr_t *allctr, void *ptr)
type = ((ErtsAllctrFixDDBlock_t *) ptr)->fix_type;
- ASSERT(ERTS_ALC_N_MIN_A_FIXED_SIZE <= type
- && type <= ERTS_ALC_N_MAX_A_FIXED_SIZE);
+ ASSERT(ERTS_ALC_N_MIN_A_FIXED_SIZE
+ <= (type & ~ERTS_ALC_FIX_NO_UNUSE));
+ ASSERT((type & ~ERTS_ALC_FIX_NO_UNUSE)
+ <= ERTS_ALC_N_MAX_A_FIXED_SIZE);
if (!ERTS_ALC_IS_CPOOL_ENABLED(allctr))
- fix_nocpool_free(allctr, type, ptr);
+ fix_nocpool_free(allctr, (type & ~ERTS_ALC_FIX_NO_UNUSE), ptr);
else {
Block_t *blk = UMEM2BLK(ptr);
Carrier_t *busy_pcrr_p;
@@ -1765,7 +1771,9 @@ handle_delayed_fix_dealloc(Allctr_t *allctr, void *ptr)
NULL, &busy_pcrr_p);
if (used_allctr == allctr) {
doit:
- fix_cpool_free(allctr, type, ptr, &busy_pcrr_p);
+ fix_cpool_free(allctr, (type & ~ERTS_ALC_FIX_NO_UNUSE),
+ ptr, &busy_pcrr_p,
+ !(type & ERTS_ALC_FIX_NO_UNUSE));
clear_busy_pool_carrier(allctr, busy_pcrr_p);
}
else {
@@ -1885,7 +1893,7 @@ handle_delayed_dealloc(Allctr_t *allctr,
if (fix)
handle_delayed_fix_dealloc(allctr, ptr);
else
- dealloc_block(allctr, ptr, 1);
+ dealloc_block(allctr, ptr, NULL, 1);
}
}
@@ -1991,15 +1999,24 @@ erts_alcu_check_delayed_dealloc(Allctr_t *allctr,
ERTS_ALCU_DD_OPS_LIM_LOW, NULL, NULL, NULL)
static void
-dealloc_block(Allctr_t *allctr, void *ptr, int dec_cc_on_redirect)
+dealloc_block(Allctr_t *allctr, void *ptr, ErtsAlcFixList_t *fix, int dec_cc_on_redirect)
{
Block_t *blk = UMEM2BLK(ptr);
ERTS_SMP_LC_ASSERT(!allctr->thread_safe
|| erts_lc_mtx_is_locked(&allctr->mutex));
- if (IS_SBC_BLK(blk))
+ if (IS_SBC_BLK(blk)) {
destroy_carrier(allctr, blk, NULL);
+#ifdef ERTS_SMP
+ if (fix && ERTS_ALC_IS_CPOOL_ENABLED(allctr)) {
+ ErtsAlcType_t type = ((ErtsAllctrFixDDBlock_t *) ptr)->fix_type;
+ if (!(type & ERTS_ALC_FIX_NO_UNUSE))
+ fix->u.cpool.used--;
+ fix->u.cpool.allocated--;
+ }
+#endif
+ }
#ifndef ERTS_SMP
else
mbc_free(allctr, ptr, NULL);
@@ -2012,6 +2029,12 @@ dealloc_block(Allctr_t *allctr, void *ptr, int dec_cc_on_redirect)
used_allctr = get_used_allctr(allctr, ERTS_ALC_TS_PREF_LOCK_NO, ptr,
NULL, &busy_pcrr_p);
if (used_allctr == allctr) {
+ if (fix) {
+ ErtsAlcType_t type = ((ErtsAllctrFixDDBlock_t *) ptr)->fix_type;
+ if (!(type & ERTS_ALC_FIX_NO_UNUSE))
+ fix->u.cpool.used--;
+ fix->u.cpool.allocated--;
+ }
mbc_free(allctr, ptr, &busy_pcrr_p);
clear_busy_pool_carrier(allctr, busy_pcrr_p);
}
@@ -5215,7 +5238,7 @@ do_erts_alcu_free(ErtsAlcType_t type, void *extra, void *p,
if (allctr->fix) {
if (ERTS_ALC_IS_CPOOL_ENABLED(allctr))
- fix_cpool_free(allctr, type, p, busy_pcrr_pp);
+ fix_cpool_free(allctr, type, p, busy_pcrr_pp, 1);
else
fix_nocpool_free(allctr, type, p);
}
diff --git a/erts/emulator/beam/erl_node_tables.c b/erts/emulator/beam/erl_node_tables.c
index bcf6311079..6d827c6bda 100644
--- a/erts/emulator/beam/erl_node_tables.c
+++ b/erts/emulator/beam/erl_node_tables.c
@@ -705,7 +705,7 @@ erts_set_this_node(Eterm sysname, Uint creation)
erts_this_node->sysname = sysname;
erts_this_node->creation = creation;
erts_this_node_sysname = erts_this_node_sysname_BUFFER;
- erts_snprintf(erts_this_node_sysname, sizeof(erts_this_node_sysname),
+ erts_snprintf(erts_this_node_sysname, sizeof(erts_this_node_sysname_BUFFER),
"%T", sysname);
(void) hash_put(&erts_node_table, (void *) erts_this_node);
@@ -794,7 +794,7 @@ void erts_init_node_tables(void)
erts_this_node->creation = 0;
erts_this_node->dist_entry = erts_this_dist_entry;
erts_this_node_sysname = erts_this_node_sysname_BUFFER;
- erts_snprintf(erts_this_node_sysname, sizeof(erts_this_node_sysname),
+ erts_snprintf(erts_this_node_sysname, sizeof(erts_this_node_sysname_BUFFER),
"%T", erts_this_node->sysname);
(void) hash_put(&erts_node_table, (void *) erts_this_node);
diff --git a/erts/emulator/beam/erl_process.c b/erts/emulator/beam/erl_process.c
index af8db519d4..b64a7f8902 100644
--- a/erts/emulator/beam/erl_process.c
+++ b/erts/emulator/beam/erl_process.c
@@ -2887,22 +2887,29 @@ scheduler_wait(int *fcalls, ErtsSchedulerData *esdp, ErtsRunQueue *rq)
}
if (aux_work) {
- flgs = erts_smp_atomic32_read_acqb(&ssi->flags);
- current_time = erts_get_monotonic_time(esdp);
- if (current_time >= erts_next_timeout_time(esdp->next_tmo_ref)) {
- if (!ERTS_SCHEDULER_IS_DIRTY(esdp) && !thr_prgr_active) {
- erts_thr_progress_active(esdp, thr_prgr_active = 1);
- sched_wall_time_change(esdp, 1);
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ flgs = erts_smp_atomic32_read_acqb(&ssi->flags);
+ current_time = erts_get_monotonic_time(esdp);
+ if (current_time >= erts_next_timeout_time(esdp->next_tmo_ref)) {
+ if (!thr_prgr_active) {
+ erts_thr_progress_active(esdp, thr_prgr_active = 1);
+ sched_wall_time_change(esdp, 1);
+ }
+ erts_bump_timers(esdp->timer_wheel, current_time);
}
- erts_bump_timers(esdp->timer_wheel, current_time);
}
}
else {
ErtsMonotonicTime timeout_time;
- timeout_time = erts_check_next_timeout_time(esdp);
- current_time = erts_get_monotonic_time(esdp);
- if (current_time >= timeout_time) {
- if (!ERTS_SCHEDULER_IS_DIRTY(esdp) && !thr_prgr_active) {
+ int do_timeout = 0;
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ timeout_time = erts_check_next_timeout_time(esdp);
+ current_time = erts_get_monotonic_time(esdp);
+ do_timeout = (current_time >= timeout_time);
+ } else
+ timeout_time = ERTS_MONOTONIC_TIME_MAX;
+ if (do_timeout) {
+ if (!thr_prgr_active) {
erts_thr_progress_active(esdp, thr_prgr_active = 1);
sched_wall_time_change(esdp, 1);
}
@@ -2926,23 +2933,28 @@ scheduler_wait(int *fcalls, ErtsSchedulerData *esdp, ErtsRunQueue *rq)
int res;
ASSERT(flgs & ERTS_SSI_FLG_TSE_SLEEPING);
ASSERT(flgs & ERTS_SSI_FLG_WAITING);
- current_time = erts_get_monotonic_time(esdp);
+ current_time = ERTS_SCHEDULER_IS_DIRTY(esdp) ? 0 :
+ erts_get_monotonic_time(esdp);
do {
Sint64 timeout;
if (current_time >= timeout_time)
break;
- timeout = ERTS_MONOTONIC_TO_NSEC(timeout_time
- - current_time
- - 1) + 1;
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ timeout = ERTS_MONOTONIC_TO_NSEC(timeout_time
+ - current_time
+ - 1) + 1;
+ } else
+ timeout = -1;
res = erts_tse_twait(ssi->event, timeout);
- current_time = erts_get_monotonic_time(esdp);
+ current_time = ERTS_SCHEDULER_IS_DIRTY(esdp) ? 0 :
+ erts_get_monotonic_time(esdp);
} while (res == EINTR);
}
}
if (!ERTS_SCHEDULER_IS_DIRTY(esdp))
erts_thr_progress_finalize_wait(esdp);
}
- if (current_time >= timeout_time)
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp) && current_time >= timeout_time)
erts_bump_timers(esdp->timer_wheel, current_time);
}
@@ -3010,9 +3022,11 @@ scheduler_wait(int *fcalls, ErtsSchedulerData *esdp, ErtsRunQueue *rq)
ASSERT(!erts_port_task_have_outstanding_io_tasks());
erl_sys_schedule(1); /* Might give us something to do */
- current_time = erts_get_monotonic_time(esdp);
- if (current_time >= erts_next_timeout_time(esdp->next_tmo_ref))
- erts_bump_timers(esdp->timer_wheel, current_time);
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ current_time = erts_get_monotonic_time(esdp);
+ if (current_time >= erts_next_timeout_time(esdp->next_tmo_ref))
+ erts_bump_timers(esdp->timer_wheel, current_time);
+ }
sys_aux_work:
#ifndef ERTS_SMP
@@ -3021,15 +3035,18 @@ scheduler_wait(int *fcalls, ErtsSchedulerData *esdp, ErtsRunQueue *rq)
aux_work = erts_atomic32_read_acqb(&ssi->aux_work);
if (aux_work) {
- if (!working)
- sched_wall_time_change(esdp, working = 1);
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ if (!working)
+ sched_wall_time_change(esdp, working = 1);
#ifdef ERTS_SMP
- if (!thr_prgr_active)
- erts_thr_progress_active(esdp, thr_prgr_active = 1);
+ if (!thr_prgr_active)
+ erts_thr_progress_active(esdp, thr_prgr_active = 1);
#endif
+ }
aux_work = handle_aux_work(&esdp->aux_work_data, aux_work, 1);
#ifdef ERTS_SMP
- if (aux_work && erts_thr_progress_update(esdp))
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp) && aux_work &&
+ erts_thr_progress_update(esdp))
erts_thr_progress_leader_update(esdp);
#endif
}
@@ -3127,7 +3144,7 @@ scheduler_wait(int *fcalls, ErtsSchedulerData *esdp, ErtsRunQueue *rq)
erl_sys_schedule(0);
- {
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
ErtsMonotonicTime current_time = erts_get_monotonic_time(esdp);
if (current_time >= erts_next_timeout_time(esdp->next_tmo_ref))
erts_bump_timers(esdp->timer_wheel, current_time);
@@ -6790,7 +6807,8 @@ suspend_scheduler(ErtsSchedulerData *esdp)
}
}
- (void) erts_get_monotonic_time(esdp);
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp))
+ (void) erts_get_monotonic_time(esdp);
erts_smp_runq_lock(esdp->run_queue);
non_empty_runq(esdp->run_queue);
@@ -6906,7 +6924,7 @@ suspend_scheduler(ErtsSchedulerData *esdp)
& ERTS_RUNQ_FLGS_QMASK);
aux_work = erts_atomic32_read_acqb(&ssi->aux_work);
if (aux_work|qmask) {
- if (!thr_prgr_active) {
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp) && !thr_prgr_active) {
erts_thr_progress_active(esdp, thr_prgr_active = 1);
sched_wall_time_change(esdp, 1);
}
@@ -6914,7 +6932,8 @@ suspend_scheduler(ErtsSchedulerData *esdp)
aux_work = handle_aux_work(&esdp->aux_work_data,
aux_work,
1);
- if (aux_work && erts_thr_progress_update(esdp))
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp) && aux_work &&
+ erts_thr_progress_update(esdp))
erts_thr_progress_leader_update(esdp);
if (qmask) {
erts_smp_runq_lock(esdp->run_queue);
@@ -6924,32 +6943,40 @@ suspend_scheduler(ErtsSchedulerData *esdp)
}
if (aux_work) {
- current_time = erts_get_monotonic_time(esdp);
- if (current_time >= erts_next_timeout_time(esdp->next_tmo_ref)) {
- if (!thr_prgr_active) {
- erts_thr_progress_active(esdp, thr_prgr_active = 1);
- sched_wall_time_change(esdp, 1);
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ current_time = erts_get_monotonic_time(esdp);
+ if (current_time >= erts_next_timeout_time(esdp->next_tmo_ref)) {
+ if (!thr_prgr_active) {
+ erts_thr_progress_active(esdp, thr_prgr_active = 1);
+ sched_wall_time_change(esdp, 1);
+ }
+ erts_bump_timers(esdp->timer_wheel, current_time);
}
- erts_bump_timers(esdp->timer_wheel, current_time);
}
}
else {
ErtsMonotonicTime timeout_time;
- timeout_time = erts_check_next_timeout_time(esdp);
- current_time = erts_get_monotonic_time(esdp);
-
- if (current_time >= timeout_time) {
+ int do_timeout = 0;
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ timeout_time = erts_check_next_timeout_time(esdp);
+ current_time = erts_get_monotonic_time(esdp);
+ do_timeout = (current_time >= timeout_time);
+ } else
+ timeout_time = ERTS_MONOTONIC_TIME_MAX;
+ if (do_timeout) {
if (!thr_prgr_active) {
erts_thr_progress_active(esdp, thr_prgr_active = 1);
sched_wall_time_change(esdp, 1);
}
}
- else {
- if (thr_prgr_active) {
- erts_thr_progress_active(esdp, thr_prgr_active = 0);
- sched_wall_time_change(esdp, 0);
+ else {
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ if (thr_prgr_active) {
+ erts_thr_progress_active(esdp, thr_prgr_active = 0);
+ sched_wall_time_change(esdp, 0);
+ }
+ erts_thr_progress_prepare_wait(esdp);
}
- erts_thr_progress_prepare_wait(esdp);
flgs = sched_spin_suspended(ssi,
ERTS_SCHED_SUSPEND_SLEEP_SPINCOUNT);
if (flgs == (ERTS_SSI_FLG_SLEEPING
@@ -6962,23 +6989,29 @@ suspend_scheduler(ErtsSchedulerData *esdp)
| ERTS_SSI_FLG_SUSPENDED)) {
int res;
- current_time = erts_get_monotonic_time(esdp);
+ current_time = ERTS_SCHEDULER_IS_DIRTY(esdp) ? 0 :
+ erts_get_monotonic_time(esdp);
do {
Sint64 timeout;
if (current_time >= timeout_time)
break;
- timeout = ERTS_MONOTONIC_TO_NSEC(timeout_time
- - current_time
- - 1) + 1;
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ timeout = ERTS_MONOTONIC_TO_NSEC(timeout_time
+ - current_time
+ - 1) + 1;
+ } else
+ timeout = -1;
res = erts_tse_twait(ssi->event, timeout);
- current_time = erts_get_monotonic_time(esdp);
+ current_time = ERTS_SCHEDULER_IS_DIRTY(esdp) ? 0 :
+ erts_get_monotonic_time(esdp);
} while (res == EINTR);
}
}
- erts_thr_progress_finalize_wait(esdp);
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp))
+ erts_thr_progress_finalize_wait(esdp);
}
- if (current_time >= timeout_time)
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp) && current_time >= timeout_time)
erts_bump_timers(esdp->timer_wheel, current_time);
}
@@ -9196,13 +9229,15 @@ Process *schedule(Process *p, int calls)
ERTS_SMP_CHK_NO_PROC_LOCKS;
- if (esdp->check_time_reds >= ERTS_CHECK_TIME_REDS)
- (void) erts_get_monotonic_time(esdp);
+ if (!ERTS_SCHEDULER_IS_DIRTY(esdp)) {
+ if (esdp->check_time_reds >= ERTS_CHECK_TIME_REDS)
+ (void) erts_get_monotonic_time(esdp);
- if (esdp->last_monotonic_time >= erts_next_timeout_time(esdp->next_tmo_ref)) {
- erts_smp_runq_unlock(rq);
- erts_bump_timers(esdp->timer_wheel, esdp->last_monotonic_time);
- erts_smp_runq_lock(rq);
+ if (esdp->last_monotonic_time >= erts_next_timeout_time(esdp->next_tmo_ref)) {
+ erts_smp_runq_unlock(rq);
+ erts_bump_timers(esdp->timer_wheel, esdp->last_monotonic_time);
+ erts_smp_runq_lock(rq);
+ }
}
BM_STOP_TIMER(system);
@@ -9649,7 +9684,7 @@ Process *schedule(Process *p, int calls)
ASSERT(erts_proc_read_refc(p) > 0);
- if (ERTS_PTMR_IS_TIMED_OUT(p)) {
+ if (!(state & ERTS_PSFLG_EXITING) && ERTS_PTMR_IS_TIMED_OUT(p)) {
BeamInstr** pi;
#ifdef ERTS_SMP
ETHR_MEMBAR(ETHR_LoadLoad|ETHR_LoadStore);
diff --git a/erts/emulator/test/monitor_SUITE.erl b/erts/emulator/test/monitor_SUITE.erl
index dc215b1529..7326dfceb1 100644
--- a/erts/emulator/test/monitor_SUITE.erl
+++ b/erts/emulator/test/monitor_SUITE.erl
@@ -665,98 +665,86 @@ list_cleanup(Config) when is_list(Config) ->
mixer(doc) ->
"Test mixing of internal and external monitors.";
mixer(Config) when is_list(Config) ->
- ?line PA = filename:dirname(code:which(?MODULE)),
- ?line NN = [j0,j1,j2,j3],
-% ?line NN = [j0,j1],
- ?line NL0 = [begin
- {ok, J} = test_server:start_node
- (X, slave, [{args, "-pa " ++ PA}]),
- J
- end || X <- NN],
- ?line NL1 = lists:duplicate(2,node()) ++ NL0,
- ?line Perm = perm(NL1),
- ?line lists:foreach(
- fun(NL) ->
- ?line Js = [ start_jeeves({[],M}) || M <- (NL ++ NL) ],
- ?line [ask_jeeves(P,{monitor_process,self()}) || P <- Js],
- ?line {monitored_by,MB} =
- process_info(self(),monitored_by),
- ?line MBL = lists:sort(MB),
- ?line JsL = lists:sort(Js),
- ?line MBL = JsL,
- ?line {monitors,[]} = process_info(self(),monitors),
- ?line [tell_jeeves(P,{exit,flaff}) || P <- Js],
- ?line wait_for_m([],[],200)
- end,
- Perm),
- ?line lists:foreach(
- fun(NL) ->
- ?line Js = [ start_jeeves({[],M}) || M <- (NL ++ NL) ],
- ?line Rs = [begin
- {monitor_process,Ref} =
- ask_jeeves(P,{monitor_process,self()}),
- {P,Ref}
- end
- || P <- Js],
- ?line {monitored_by,MB} =
- process_info(self(),monitored_by),
- ?line MBL = lists:sort(MB),
- ?line JsL = lists:sort(Js),
- ?line MBL = JsL,
- ?line {monitors,[]} = process_info(self(),monitors),
- ?line [ask_jeeves(P,{demonitor,Ref}) || {P,Ref} <- Rs],
- ?line wait_for_m([],[],200),
- ?line [tell_jeeves(P,{exit,flaff}) || P <- Js]
- end,
- Perm),
- ?line lists:foreach(
- fun(NL) ->
- ?line Js = [ start_jeeves({[],M}) || M <- (NL ++ NL) ],
- ?line [ask_jeeves(P,{monitor_process,self()}) || P <- Js],
- ?line [erlang:monitor(process,P) || P <- Js],
- ?line {monitored_by,MB} =
- process_info(self(),monitored_by),
- ?line MBL = lists:sort(MB),
- ?line JsL = lists:sort(Js),
- ?line MBL = JsL,
- ?line {monitors,M} =
- process_info(self(),monitors),
- ?line ML = lists:sort([P||{process,P} <- M]),
- ?line ML = JsL,
- ?line [begin
- tell_jeeves(P,{exit,flaff}),
- receive {'DOWN',_,process,P,_} -> ok end
- end || P <- Js],
- ?line wait_for_m([],[],200)
- end,
- Perm),
- ?line lists:foreach(
- fun(NL) ->
- ?line Js = [ start_jeeves({[],M}) || M <- (NL ++ NL) ],
- ?line Rs = [begin
- {monitor_process,Ref} =
- ask_jeeves(P,{monitor_process,self()}),
- {P,Ref}
- end
- || P <- Js],
- ?line R2s = [{P,erlang:monitor(process,P)} || P <- Js],
- ?line {monitored_by,MB} =
- process_info(self(),monitored_by),
- ?line MBL = lists:sort(MB),
- ?line JsL = lists:sort(Js),
- ?line MBL = JsL,
- ?line {monitors,M} =
- process_info(self(),monitors),
- ?line ML = lists:sort([P||{process,P} <- M]),
- ?line ML = JsL,
- ?line [ask_jeeves(P,{demonitor,Ref}) || {P,Ref} <- Rs],
- ?line wait_for_m(lists:sort(M),[],200),
- ?line [erlang:demonitor(Ref) || {_P,Ref} <- R2s],
- ?line wait_for_m([],[],200),
- ?line [tell_jeeves(P,{exit,flaff}) || P <- Js]
- end,
- Perm),
- [test_server:stop_node(K) || K <- NL0 ],
+ PA = filename:dirname(code:which(?MODULE)),
+ NN = [j0,j1,j2],
+ NL0 = [begin
+ {ok, J} = test_server:start_node(X,slave,[{args, "-pa " ++ PA}]),
+ J
+ end || X <- NN],
+ NL1 = lists:duplicate(2,node()) ++ NL0,
+ Perm = perm(NL1),
+ lists:foreach(
+ fun(NL) ->
+ Js = [start_jeeves({[],M}) || M <- (NL ++ NL)],
+ [ask_jeeves(P,{monitor_process,self()}) || P <- Js],
+ {monitored_by,MB} = process_info(self(),monitored_by),
+ MBL = lists:sort(MB),
+ JsL = lists:sort(Js),
+ MBL = JsL,
+ {monitors,[]} = process_info(self(),monitors),
+ [tell_jeeves(P,{exit,flaff}) || P <- Js],
+ wait_for_m([],[],200)
+ end,
+ Perm),
+ lists:foreach(
+ fun(NL) ->
+ Js = [start_jeeves({[],M}) || M <- (NL ++ NL)],
+ Rs = [begin
+ {monitor_process,Ref} = ask_jeeves(P,{monitor_process,self()}),
+ {P,Ref}
+ end || P <- Js],
+ {monitored_by,MB} = process_info(self(),monitored_by),
+ MBL = lists:sort(MB),
+ JsL = lists:sort(Js),
+ MBL = JsL,
+ {monitors,[]} = process_info(self(),monitors),
+ [ask_jeeves(P,{demonitor,Ref}) || {P,Ref} <- Rs],
+ wait_for_m([],[],200),
+ [tell_jeeves(P,{exit,flaff}) || P <- Js]
+ end,
+ Perm),
+ lists:foreach(
+ fun(NL) ->
+ Js = [start_jeeves({[],M}) || M <- (NL ++ NL)],
+ [ask_jeeves(P,{monitor_process,self()}) || P <- Js],
+ [erlang:monitor(process,P) || P <- Js],
+ {monitored_by,MB} = process_info(self(),monitored_by),
+ MBL = lists:sort(MB),
+ JsL = lists:sort(Js),
+ MBL = JsL,
+ {monitors,M} = process_info(self(),monitors),
+ ML = lists:sort([P||{process,P} <- M]),
+ ML = JsL,
+ [begin
+ tell_jeeves(P,{exit,flaff}),
+ receive {'DOWN',_,process,P,_} -> ok end
+ end || P <- Js],
+ wait_for_m([],[],200)
+ end,
+ Perm),
+ lists:foreach(
+ fun(NL) ->
+ Js = [start_jeeves({[],M}) || M <- (NL ++ NL)],
+ Rs = [begin
+ {monitor_process,Ref} = ask_jeeves(P,{monitor_process,self()}),
+ {P,Ref}
+ end || P <- Js],
+ R2s = [{P,erlang:monitor(process,P)} || P <- Js],
+ {monitored_by,MB} = process_info(self(),monitored_by),
+ MBL = lists:sort(MB),
+ JsL = lists:sort(Js),
+ MBL = JsL,
+ {monitors,M} = process_info(self(),monitors),
+ ML = lists:sort([P||{process,P} <- M]),
+ ML = JsL,
+ [ask_jeeves(P,{demonitor,Ref}) || {P,Ref} <- Rs],
+ wait_for_m(lists:sort(M),[],200),
+ [erlang:demonitor(Ref) || {_P,Ref} <- R2s],
+ wait_for_m([],[],200),
+ [tell_jeeves(P,{exit,flaff}) || P <- Js]
+ end,
+ Perm),
+ [test_server:stop_node(K) || K <- NL0],
ok.
named_down(doc) -> ["Test that DOWN message for a named monitor isn't"
diff --git a/erts/etc/ose/run_erl.c b/erts/etc/ose/run_erl.c
index 8bc49a485e..a6499f2bf3 100644
--- a/erts/etc/ose/run_erl.c
+++ b/erts/etc/ose/run_erl.c
@@ -615,7 +615,7 @@ int run_erl(int argc,char **argv) {
returns */
PROCESS main_pid;
hunt_in_block("run_erl","main",&main_pid);
- sig = alloc(sizeof(sig),ERTS_SIGNAL_RUN_ERL_DAEMON);
+ sig = alloc(sizeof(*sig),ERTS_SIGNAL_RUN_ERL_DAEMON);
send(&sig,main_pid);
sig = receive(sigsel);
pid = sender(&sig);
diff --git a/lib/.gitignore b/lib/.gitignore
index 4125111ebd..58c49adce0 100644
--- a/lib/.gitignore
+++ b/lib/.gitignore
@@ -546,6 +546,8 @@ snmp/doc/intex.html
/syntax_tools/doc/src/erl_syntax.xml
/syntax_tools/doc/src/erl_syntax_lib.xml
/syntax_tools/doc/src/erl_tidy.xml
+/syntax_tools/doc/src/merl.xml
+/syntax_tools/doc/src/merl_transform.xml
/syntax_tools/doc/src/igor.xml
/syntax_tools/doc/src/prettypr.xml
diff --git a/lib/asn1/doc/src/asn1ct.xml b/lib/asn1/doc/src/asn1ct.xml
index 4e0bf055fc..30808a5ead 100644
--- a/lib/asn1/doc/src/asn1ct.xml
+++ b/lib/asn1/doc/src/asn1ct.xml
@@ -371,6 +371,15 @@ File3.asn</pre>
representation of a value of the <c>ASN.1</c> type <c>Type</c>. The value
is a random value and subsequent calls to this function will for most
types return different values.</p>
+ <note>
+ <p>Currently, the <c>value</c> function has many limitations.
+ Essentially, it will mostly work for old specifications based
+ on the 1997 standard for ASN.1, but not for most modern-style
+ applications. Another limitation is that the <c>value</c> function
+ may not work if options that change code generations strategies
+ such as the options <c>macro_name_prefix</c> and
+ <c>record_name_prefix</c> have been used.</p>
+ </note>
</desc>
</func>
@@ -391,6 +400,15 @@ File3.asn</pre>
This function is useful during test to secure that the generated
encode and decode functions as well as the general runtime support
work as expected.</p>
+ <note>
+ <p>Currently, the <c>test</c> functions have many limitations.
+ Essentially, they will mostly work for old specifications based
+ on the 1997 standard for ASN.1, but not for most modern-style
+ applications. Another limitation is that the <c>test</c> functions
+ may not work if options that change code generations strategies
+ such as the options <c>macro_name_prefix</c> and
+ <c>record_name_prefix</c> have been used.</p>
+ </note>
<list type="bulleted">
<item>
<p><c>test/1</c> iterates over all types in <c>Module</c>.</p>
diff --git a/lib/asn1/vsn.mk b/lib/asn1/vsn.mk
index c909c908d6..d4c46863a3 100644
--- a/lib/asn1/vsn.mk
+++ b/lib/asn1/vsn.mk
@@ -1 +1 @@
-ASN1_VSN = 3.0.4
+ASN1_VSN = 4.0
diff --git a/lib/compiler/src/Makefile b/lib/compiler/src/Makefile
index 7c4cebdc28..78efc8dff0 100644
--- a/lib/compiler/src/Makefile
+++ b/lib/compiler/src/Makefile
@@ -70,6 +70,7 @@ MODULES = \
cerl \
cerl_clauses \
cerl_inline \
+ cerl_sets \
cerl_trees \
compile \
core_lib \
diff --git a/lib/compiler/src/beam_dead.erl b/lib/compiler/src/beam_dead.erl
index 5932d8ce1d..bbe607cf19 100644
--- a/lib/compiler/src/beam_dead.erl
+++ b/lib/compiler/src/beam_dead.erl
@@ -96,7 +96,7 @@ move_move_into_block([], Acc) -> reverse(Acc).
%%%
forward(Is, Lc) ->
- forward(Is, gb_trees:empty(), Lc, []).
+ forward(Is, #{}, Lc, []).
forward([{move,_,_}=Move|[{label,L}|_]=Is], D, Lc, Acc) ->
%% move/2 followed by jump/1 is optimized by backward/3.
@@ -115,19 +115,20 @@ forward([{label,Lbl}=LblI,{block,[{set,[Dst],[Lit],move}|BlkIs]}=Blk|Is], D, Lc,
%% cannot be reached in any other way than through the select_val/3
%% instruction (i.e. there can be no fallthrough to such label and
%% it cannot be referenced by, for example, a jump/1 instruction).
- Block = case gb_trees:lookup({Lbl,Dst}, D) of
- {value,Lit} -> {block,BlkIs}; %Safe to remove move instruction.
- _ -> Blk %Must keep move instruction.
- end,
+ Key = {Lbl,Dst},
+ Block = case D of
+ #{Key := Lit} -> {block,BlkIs}; %Safe to remove move instruction.
+ _ -> Blk %Must keep move instruction.
+ end,
forward([Block|Is], D, Lc, [LblI|Acc]);
forward([{label,Lbl}=LblI|[{move,Lit,Dst}|Is1]=Is0], D, Lc, Acc) ->
%% Assumption: The target labels in a select_val/3 instruction
%% cannot be reached in any other way than through the select_val/3
%% instruction (i.e. there can be no fallthrough to such label and
%% it cannot be referenced by, for example, a jump/1 instruction).
- Is = case gb_trees:lookup({Lbl,Dst}, D) of
- {value,Lit} -> Is1; %Safe to remove move instruction.
- _ -> Is0 %Keep move instruction.
+ Is = case maps:find({Lbl,Dst}, D) of
+ {ok,Lit} -> Is1; %Safe to remove move instruction.
+ _ -> Is0 %Keep move instruction.
end,
forward(Is, D, Lc, [LblI|Acc]);
forward([{test,is_eq_exact,_,[Same,Same]}|Is], D, Lc, Acc) ->
@@ -156,11 +157,11 @@ forward([], _, Lc, Acc) -> {Acc,Lc}.
update_value_dict([Lit,{f,Lbl}|T], Reg, D0) ->
Key = {Lbl,Reg},
- D = case gb_trees:lookup(Key, D0) of
- none -> gb_trees:insert(Key, Lit, D0); %New.
- {value,inconsistent} -> D0; %Inconsistent.
- {value,_} -> gb_trees:update(Key, inconsistent, D0)
- end,
+ D = case D0 of
+ #{Key := inconsistent} -> D0;
+ #{Key := _} -> D0#{Key := inconsistent};
+ _ -> D0#{Key => Lit}
+ end,
update_value_dict(T, Reg, D);
update_value_dict([], _, D) -> D.
diff --git a/lib/compiler/src/beam_dict.erl b/lib/compiler/src/beam_dict.erl
index 68dc104dd3..b1aa98278e 100644
--- a/lib/compiler/src/beam_dict.erl
+++ b/lib/compiler/src/beam_dict.erl
@@ -31,22 +31,22 @@
-type index() :: non_neg_integer().
--type atom_tab() :: gb_trees:tree(atom(), index()).
+-type atom_tab() :: #{atom() => index()}.
-type import_tab() :: gb_trees:tree(mfa(), index()).
--type fname_tab() :: gb_trees:tree(Name :: term(), index()).
--type line_tab() :: gb_trees:tree({Fname :: index(), Line :: term()}, index()).
+-type fname_tab() :: #{Name :: term() => index()}.
+-type line_tab() :: #{{Fname :: index(), Line :: term()} => index()}.
-type literal_tab() :: dict:dict(Literal :: term(), index()).
-record(asm,
- {atoms = gb_trees:empty() :: atom_tab(),
+ {atoms = #{} :: atom_tab(),
exports = [] :: [{label(), arity(), label()}],
locals = [] :: [{label(), arity(), label()}],
imports = gb_trees:empty() :: import_tab(),
strings = <<>> :: binary(), %String pool
lambdas = [], %[{...}]
literals = dict:new() :: literal_tab(),
- fnames = gb_trees:empty() :: fname_tab(),
- lines = gb_trees:empty() :: line_tab(),
+ fnames = #{} :: fname_tab(),
+ lines = #{} :: line_tab(),
num_lines = 0 :: non_neg_integer(), %Number of line instructions
next_import = 0 :: non_neg_integer(),
string_offset = 0 :: non_neg_integer(),
@@ -77,14 +77,12 @@ highest_opcode(#asm{highest_opcode=Op}) -> Op.
%% atom(Atom, Dict) -> {Index,Dict'}
-spec atom(atom(), bdict()) -> {pos_integer(), bdict()}.
-atom(Atom, #asm{atoms=Atoms0}=Dict) when is_atom(Atom) ->
- case gb_trees:lookup(Atom, Atoms0) of
- {value,Index} ->
- {Index,Dict};
- none ->
- NextIndex = gb_trees:size(Atoms0) + 1,
- Atoms = gb_trees:insert(Atom, NextIndex, Atoms0),
- {NextIndex,Dict#asm{atoms=Atoms}}
+atom(Atom, #asm{atoms=Atoms}=Dict) when is_atom(Atom) ->
+ case Atoms of
+ #{ Atom := Index} -> {Index,Dict};
+ _ ->
+ NextIndex = maps:size(Atoms) + 1,
+ {NextIndex,Dict#asm{atoms=Atoms#{Atom=>NextIndex}}}
end.
%% Remembers an exported function.
@@ -177,26 +175,22 @@ line([], #asm{num_lines=N}=Dict) ->
%% No location available. Return the special pre-defined
%% index 0.
{0,Dict#asm{num_lines=N+1}};
-line([{location,Name,Line}], #asm{lines=Lines0,num_lines=N}=Dict0) ->
+line([{location,Name,Line}], #asm{lines=Lines,num_lines=N}=Dict0) ->
{FnameIndex,Dict1} = fname(Name, Dict0),
- case gb_trees:lookup({FnameIndex,Line}, Lines0) of
- {value,Index} ->
- {Index,Dict1#asm{num_lines=N+1}};
- none ->
- Index = gb_trees:size(Lines0) + 1,
- Lines = gb_trees:insert({FnameIndex,Line}, Index, Lines0),
- Dict = Dict1#asm{lines=Lines,num_lines=N+1},
- {Index,Dict}
+ Key = {FnameIndex,Line},
+ case Lines of
+ #{Key := Index} -> {Index,Dict1#asm{num_lines=N+1}};
+ _ ->
+ Index = maps:size(Lines) + 1,
+ {Index, Dict1#asm{lines=Lines#{Key=>Index},num_lines=N+1}}
end.
-fname(Name, #asm{fnames=Fnames0}=Dict) ->
- case gb_trees:lookup(Name, Fnames0) of
- {value,Index} ->
- {Index,Dict};
- none ->
- Index = gb_trees:size(Fnames0),
- Fnames = gb_trees:insert(Name, Index, Fnames0),
- {Index,Dict#asm{fnames=Fnames}}
+fname(Name, #asm{fnames=Fnames}=Dict) ->
+ case Fnames of
+ #{Name := Index} -> {Index,Dict};
+ _ ->
+ Index = maps:size(Fnames),
+ {Index,Dict#asm{fnames=Fnames#{Name=>Index}}}
end.
%% Returns the atom table.
@@ -204,14 +198,12 @@ fname(Name, #asm{fnames=Fnames0}=Dict) ->
-spec atom_table(bdict()) -> {non_neg_integer(), [[non_neg_integer(),...]]}.
atom_table(#asm{atoms=Atoms}) ->
- NumAtoms = gb_trees:size(Atoms),
- Sorted = lists:keysort(2, gb_trees:to_list(Atoms)),
- Fun = fun({A,_}) ->
- L = atom_to_list(A),
- [length(L)|L]
- end,
- AtomTab = lists:map(Fun, Sorted),
- {NumAtoms,AtomTab}.
+ NumAtoms = maps:size(Atoms),
+ Sorted = lists:keysort(2, maps:to_list(Atoms)),
+ {NumAtoms,[begin
+ L = atom_to_list(A),
+ [length(L)|L]
+ end || {A,_} <- Sorted]}.
%% Returns the table of local functions.
%% local_table(Dict) -> {NumLocals, [{Function, Arity, Label}...]}
@@ -273,11 +265,11 @@ my_term_to_binary(Term) ->
non_neg_integer(),[{non_neg_integer(),non_neg_integer()}]}.
line_table(#asm{fnames=Fnames0,lines=Lines0,num_lines=NumLineInstrs}) ->
- NumFnames = gb_trees:size(Fnames0),
- Fnames1 = lists:keysort(2, gb_trees:to_list(Fnames0)),
+ NumFnames = maps:size(Fnames0),
+ Fnames1 = lists:keysort(2, maps:to_list(Fnames0)),
Fnames = [Name || {Name,_} <- Fnames1],
- NumLines = gb_trees:size(Lines0),
- Lines1 = lists:keysort(2, gb_trees:to_list(Lines0)),
+ NumLines = maps:size(Lines0),
+ Lines1 = lists:keysort(2, maps:to_list(Lines0)),
Lines = [L || {L,_} <- Lines1],
{NumLineInstrs,NumFnames,Fnames,NumLines,Lines}.
diff --git a/lib/compiler/src/beam_jump.erl b/lib/compiler/src/beam_jump.erl
index 52b6464c7f..80b2998ddc 100644
--- a/lib/compiler/src/beam_jump.erl
+++ b/lib/compiler/src/beam_jump.erl
@@ -152,14 +152,14 @@ function({function,Name,Arity,CLabel,Asm0}) ->
share(Is0) ->
%% We will get more sharing if we never fall through to a label.
Is = eliminate_fallthroughs(Is0, []),
- share_1(Is, dict:new(), [], []).
+ share_1(Is, #{}, [], []).
share_1([{label,_}=Lbl|Is], Dict, [], Acc) ->
share_1(Is, Dict, [], [Lbl|Acc]);
share_1([{label,L}=Lbl|Is], Dict0, Seq, Acc) ->
- case dict:find(Seq, Dict0) of
+ case maps:find(Seq, Dict0) of
error ->
- Dict = dict:store(Seq, L, Dict0),
+ Dict = maps:put(Seq, L, Dict0),
share_1(Is, Dict, [], [Lbl|Seq ++ Acc]);
{ok,Label} ->
share_1(Is, Dict0, [], [Lbl,{jump,{f,Label}}|Acc])
@@ -188,7 +188,7 @@ clean_non_sharable(Dict) ->
%% a sequence inside the 'try' block is a sequence that ends
%% with an instruction that causes an exception. Any sequence
%% that causes an exception must contain a line/1 instruction.
- dict:filter(fun(K, _V) -> sharable_with_try(K) end, Dict).
+ maps:filter(fun(K, _V) -> sharable_with_try(K) end, Dict).
sharable_with_try([{line,_}|_]) ->
%% This sequence may cause an exception and may potentially
@@ -268,13 +268,13 @@ extract_seq_1(_, _) -> no.
-record(st, {fc, %Label for function class errors.
entry, %Entry label (must not be moved).
mlbl, %Moved labels.
- labels %Set of referenced labels.
+ labels :: cerl_sets:set() %Set of referenced labels.
}).
opt([{label,Fc}|_]=Is0, CLabel) ->
Lbls = initial_labels(Is0),
find_fixpoint(fun(Is) ->
- St = #st{fc=Fc,entry=CLabel,mlbl=dict:new(),
+ St = #st{fc=Fc,entry=CLabel,mlbl=#{},
labels=Lbls},
opt(Is, [], St)
end, Is0).
@@ -320,11 +320,11 @@ opt([{test,_,{f,_}=Lbl,_,_,_}=I|Is], Acc, St) ->
opt([{select,_,_R,Fail,Vls}=I|Is], Acc, St) ->
skip_unreachable(Is, [I|Acc], label_used([Fail|Vls], St));
opt([{label,Lbl}=I|Is], Acc, #st{mlbl=Mlbl}=St0) ->
- case dict:find(Lbl, Mlbl) of
+ case maps:find(Lbl, Mlbl) of
{ok,Lbls} ->
%% Essential to remove the list of labels from the dictionary,
%% since we will rescan the inserted labels. We MUST rescan.
- St = St0#st{mlbl=dict:erase(Lbl, Mlbl)},
+ St = St0#st{mlbl=maps:remove(Lbl, Mlbl)},
insert_labels([Lbl|Lbls], Is, Acc, St);
error -> opt(Is, [I|Acc], St0)
end;
@@ -339,7 +339,7 @@ opt([{jump,{f,L}=Lbl}=I|Is], Acc0, #st{mlbl=Mlbl0}=St0) ->
St = case Lbls of
[] -> St0;
[_|_] ->
- Mlbl = dict:append_list(L, Lbls, Mlbl0),
+ Mlbl = maps_append_list(L, Lbls, Mlbl0),
St0#st{mlbl=Mlbl}
end,
skip_unreachable(Is, [I|Acc], label_used(Lbl, St));
@@ -363,14 +363,20 @@ opt([I|Is], Acc, #st{labels=Used0}=St0) ->
end;
opt([], Acc, #st{fc=Fc,mlbl=Mlbl}) ->
Code = reverse(Acc),
- case dict:find(Fc, Mlbl) of
+ case maps:find(Fc, Mlbl) of
{ok,Lbls} -> insert_fc_labels(Lbls, Mlbl, Code);
error -> Code
end.
+maps_append_list(K,Vs,M) ->
+ case M of
+ #{K:=Vs0} -> M#{K:=Vs0++Vs}; % same order as dict
+ _ -> M#{K => Vs}
+ end.
+
insert_fc_labels([L|Ls], Mlbl, Acc0) ->
Acc = [{label,L}|Acc0],
- case dict:find(L, Mlbl) of
+ case maps:find(L, Mlbl) of
error ->
insert_fc_labels(Ls, Mlbl, Acc);
{ok,Lbls} ->
@@ -434,7 +440,7 @@ skip_unreachable([], Acc, St) ->
%% Add one or more label to the set of used labels.
-label_used({f,L}, St) -> St#st{labels=gb_sets:add(L, St#st.labels)};
+label_used({f,L}, St) -> St#st{labels=cerl_sets:add_element(L,St#st.labels)};
label_used([H|T], St0) -> label_used(T, label_used(H, St0));
label_used([], St) -> St;
label_used(_Other, St) -> St.
@@ -442,7 +448,7 @@ label_used(_Other, St) -> St.
%% Test if label is used.
is_label_used(L, St) ->
- gb_sets:is_member(L, St#st.labels).
+ cerl_sets:is_element(L, St#st.labels).
%% is_unreachable_after(Instruction) -> boolean()
%% Test whether the code after Instruction is unreachable.
@@ -472,14 +478,14 @@ is_exit_instruction(_) -> false.
%% (including inside blocks).
is_label_used_in(Lbl, Is) ->
- is_label_used_in_1(Is, Lbl, gb_sets:empty()).
+ is_label_used_in_1(Is, Lbl, cerl_sets:new()).
is_label_used_in_1([{block,Block}|Is], Lbl, Empty) ->
lists:any(fun(I) -> is_label_used_in_block(I, Lbl) end, Block)
orelse is_label_used_in_1(Is, Lbl, Empty);
is_label_used_in_1([I|Is], Lbl, Empty) ->
Used = ulbl(I, Empty),
- gb_sets:is_member(Lbl, Used) orelse is_label_used_in_1(Is, Lbl, Empty);
+ cerl_sets:is_element(Lbl, Used) orelse is_label_used_in_1(Is, Lbl, Empty);
is_label_used_in_1([], _, _) -> false.
is_label_used_in_block({set,_,_,Info}, Lbl) ->
@@ -506,7 +512,7 @@ remove_unused_labels(Is) ->
rem_unused(Is, Used, []).
rem_unused([{label,Lbl}=I|Is0], Used, [Prev|_]=Acc) ->
- case gb_sets:is_member(Lbl, Used) of
+ case cerl_sets:is_element(Lbl, Used) of
false ->
Is = case is_unreachable_after(Prev) of
true -> drop_upto_label(Is0);
@@ -528,7 +534,7 @@ initial_labels([{line,_}|Is], Acc) ->
initial_labels([{label,Lbl}|Is], Acc) ->
initial_labels(Is, [Lbl|Acc]);
initial_labels([{func_info,_,_,_},{label,Lbl}|_], Acc) ->
- gb_sets:from_list([Lbl|Acc]).
+ cerl_sets:from_list([Lbl|Acc]).
drop_upto_label([{label,_}|_]=Is) -> Is;
drop_upto_label([_|Is]) -> drop_upto_label(Is);
@@ -576,10 +582,10 @@ ulbl({get_map_elements,Lbl,_Src,_List}, Used) ->
ulbl(_, Used) -> Used.
mark_used({f,0}, Used) -> Used;
-mark_used({f,L}, Used) -> gb_sets:add(L, Used).
+mark_used({f,L}, Used) -> cerl_sets:add_element(L, Used).
mark_used_list([{f,L}|T], Used) ->
- mark_used_list(T, gb_sets:add(L, Used));
+ mark_used_list(T, cerl_sets:add_element(L, Used));
mark_used_list([_|T], Used) ->
mark_used_list(T, Used);
mark_used_list([], Used) -> Used.
diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl
index 4731b5e78e..7ab548152e 100644
--- a/lib/compiler/src/beam_type.erl
+++ b/lib/compiler/src/beam_type.erl
@@ -554,10 +554,10 @@ flush(Rs, [{set,[_],[],{put_tuple,_}}|_]=Is0, Acc0) ->
Acc = flush_all(Rs, Is0, Acc0),
{[],Acc};
flush(Rs0, [{set,Ds,Ss,_Op}|_], Acc0) ->
- Save = gb_sets:from_list(Ss),
+ Save = cerl_sets:from_list(Ss),
Acc = save_regs(Rs0, Save, Acc0),
Rs1 = foldl(fun(S, A) -> mark(S, A, clean) end, Rs0, Ss),
- Kill = gb_sets:from_list(Ds),
+ Kill = cerl_sets:from_list(Ds),
Rs = kill_regs(Rs1, Kill),
{Rs,Acc};
flush(Rs0, Is, Acc0) ->
@@ -580,7 +580,7 @@ save_regs(Rs, Save, Acc) ->
foldl(fun(R, A) -> save_reg(R, Save, A) end, Acc, Rs).
save_reg({I,V,dirty}, Save, Acc) ->
- case gb_sets:is_member(V, Save) of
+ case cerl_sets:is_element(V, Save) of
true -> [{set,[V],[{fr,I}],fmove}|checkerror(Acc)];
false -> Acc
end;
@@ -590,7 +590,7 @@ kill_regs(Rs, Kill) ->
[kill_reg(R, Kill) || R <- Rs].
kill_reg({_,V,_}=R, Kill) ->
- case gb_sets:is_member(V, Kill) of
+ case cerl_sets:is_element(V, Kill) of
true -> free;
false -> R
end;
diff --git a/lib/compiler/src/cerl_sets.erl b/lib/compiler/src/cerl_sets.erl
new file mode 100644
index 0000000000..4df78dc432
--- /dev/null
+++ b/lib/compiler/src/cerl_sets.erl
@@ -0,0 +1,206 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2000-2015. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-module(cerl_sets).
+
+%% Standard interface.
+-export([new/0,is_set/1,size/1,to_list/1,from_list/1]).
+-export([is_element/2,add_element/2,del_element/2]).
+-export([union/2,union/1,intersection/2,intersection/1]).
+-export([is_disjoint/2]).
+-export([subtract/2,is_subset/2]).
+-export([fold/3,filter/2]).
+
+-export_type([set/0, set/1]).
+
+%%------------------------------------------------------------------------------
+
+-type set() :: set(_).
+-opaque set(Element) :: #{Element => 'ok'}.
+
+%%------------------------------------------------------------------------------
+
+%% new() -> Set
+-spec new() -> set().
+
+new() -> #{}.
+
+%% is_set(Set) -> boolean().
+%% Return 'true' if Set is a set of elements, else 'false'.
+-spec is_set(Set) -> boolean() when
+ Set :: term().
+
+is_set(S) when is_map(S) -> true;
+is_set(_) -> false.
+
+%% size(Set) -> int().
+%% Return the number of elements in Set.
+-spec size(Set) -> non_neg_integer() when
+ Set :: set().
+
+size(S) -> maps:size(S).
+
+%% to_list(Set) -> [Elem].
+%% Return the elements in Set as a list.
+-spec to_list(Set) -> List when
+ Set :: set(Element),
+ List :: [Element].
+
+to_list(S) -> maps:keys(S).
+
+%% from_list([Elem]) -> Set.
+%% Build a set from the elements in List.
+-spec from_list(List) -> Set when
+ List :: [Element],
+ Set :: set(Element).
+from_list(Ls) -> maps:from_list([{K,ok}||K<-Ls]).
+
+%% is_element(Element, Set) -> boolean().
+%% Return 'true' if Element is an element of Set, else 'false'.
+-spec is_element(Element, Set) -> boolean() when
+ Set :: set(Element).
+
+is_element(E,S) ->
+ case S of
+ #{E := _} -> true;
+ _ -> false
+ end.
+
+%% add_element(Element, Set) -> Set.
+%% Return Set with Element inserted in it.
+-spec add_element(Element, Set1) -> Set2 when
+ Set1 :: set(Element),
+ Set2 :: set(Element).
+
+add_element(E,S) -> S#{E=>ok}.
+
+-spec del_element(Element, Set1) -> Set2 when
+ Set1 :: set(Element),
+ Set2 :: set(Element).
+
+%% del_element(Element, Set) -> Set.
+%% Return Set but with Element removed.
+del_element(E,S) -> maps:remove(E,S).
+
+%% union(Set1, Set2) -> Set
+%% Return the union of Set1 and Set2.
+-spec union(Set1, Set2) -> Set3 when
+ Set1 :: set(Element),
+ Set2 :: set(Element),
+ Set3 :: set(Element).
+
+union(S1,S2) -> maps:merge(S1,S2).
+
+%% union([Set]) -> Set
+%% Return the union of the list of sets.
+-spec union(SetList) -> Set when
+ SetList :: [set(Element)],
+ Set :: set(Element).
+
+union([S1,S2|Ss]) ->
+ union1(union(S1, S2), Ss);
+union([S]) -> S;
+union([]) -> new().
+
+union1(S1, [S2|Ss]) ->
+ union1(union(S1, S2), Ss);
+union1(S1, []) -> S1.
+
+%% intersection(Set1, Set2) -> Set.
+%% Return the intersection of Set1 and Set2.
+-spec intersection(Set1, Set2) -> Set3 when
+ Set1 :: set(Element),
+ Set2 :: set(Element),
+ Set3 :: set(Element).
+
+intersection(S1, S2) ->
+ filter(fun (E) -> is_element(E, S1) end, S2).
+
+%% intersection([Set]) -> Set.
+%% Return the intersection of the list of sets.
+-spec intersection(SetList) -> Set when
+ SetList :: [set(Element),...],
+ Set :: set(Element).
+
+intersection([S1,S2|Ss]) ->
+ intersection1(intersection(S1, S2), Ss);
+intersection([S]) -> S.
+
+intersection1(S1, [S2|Ss]) ->
+ intersection1(intersection(S1, S2), Ss);
+intersection1(S1, []) -> S1.
+
+%% is_disjoint(Set1, Set2) -> boolean().
+%% Check whether Set1 and Set2 are disjoint.
+-spec is_disjoint(Set1, Set2) -> boolean() when
+ Set1 :: set(Element),
+ Set2 :: set(Element).
+
+is_disjoint(S1, S2) when map_size(S1) < map_size(S2) ->
+ fold(fun (_, false) -> false;
+ (E, true) -> not is_element(E, S2)
+ end, true, S1);
+is_disjoint(S1, S2) ->
+ fold(fun (_, false) -> false;
+ (E, true) -> not is_element(E, S1)
+ end, true, S2).
+
+%% subtract(Set1, Set2) -> Set.
+%% Return all and only the elements of Set1 which are not also in
+%% Set2.
+-spec subtract(Set1, Set2) -> Set3 when
+ Set1 :: set(Element),
+ Set2 :: set(Element),
+ Set3 :: set(Element).
+
+subtract(S1, S2) ->
+ filter(fun (E) -> not is_element(E, S2) end, S1).
+
+%% is_subset(Set1, Set2) -> boolean().
+%% Return 'true' when every element of Set1 is also a member of
+%% Set2, else 'false'.
+-spec is_subset(Set1, Set2) -> boolean() when
+ Set1 :: set(Element),
+ Set2 :: set(Element).
+
+is_subset(S1, S2) ->
+ fold(fun (E, Sub) -> Sub andalso is_element(E, S2) end, true, S1).
+
+%% fold(Fun, Accumulator, Set) -> Accumulator.
+%% Fold function Fun over all elements in Set and return Accumulator.
+-spec fold(Function, Acc0, Set) -> Acc1 when
+ Function :: fun((Element, AccIn) -> AccOut),
+ Set :: set(Element),
+ Acc0 :: Acc,
+ Acc1 :: Acc,
+ AccIn :: Acc,
+ AccOut :: Acc.
+
+fold(F, Init, D) ->
+ lists:foldl(fun(E,Acc) -> F(E,Acc) end,Init,maps:keys(D)).
+
+%% filter(Fun, Set) -> Set.
+%% Filter Set with Fun.
+-spec filter(Pred, Set1) -> Set2 when
+ Pred :: fun((Element) -> boolean()),
+ Set1 :: set(Element),
+ Set2 :: set(Element).
+
+filter(F, D) ->
+ maps:from_list(lists:filter(fun({K,_}) -> F(K) end, maps:to_list(D))).
diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src
index 17d1bd91ce..0bfd998301 100644
--- a/lib/compiler/src/compiler.app.src
+++ b/lib/compiler/src/compiler.app.src
@@ -45,6 +45,7 @@
cerl,
cerl_clauses,
cerl_inline,
+ cerl_sets,
cerl_trees,
compile,
core_scan,
diff --git a/lib/compiler/src/sys_core_fold.erl b/lib/compiler/src/sys_core_fold.erl
index 6f8279f65e..102a6951e8 100644
--- a/lib/compiler/src/sys_core_fold.erl
+++ b/lib/compiler/src/sys_core_fold.erl
@@ -92,10 +92,10 @@
-endif.
%% Variable value info.
--record(sub, {v=[], %Variable substitutions
- s=[], %Variables in scope
- t=[], %Types
- in_guard=false}). %In guard or not.
+-record(sub, {v=[], %Variable substitutions
+ s=cerl_sets:new() :: cerl_sets:set(), %Variables in scope
+ t=#{} :: map(), %Types
+ in_guard=false}). %In guard or not.
-type type_info() :: cerl:cerl() | 'bool' | 'integer'.
-type yes_no_maybe() :: 'yes' | 'no' | 'maybe'.
@@ -1123,7 +1123,7 @@ let_substs(Vs0, As0, Sub0) ->
{Vs2,As1,Ss} = let_substs_1(Vs1, As0, Sub1),
Sub2 = sub_add_scope([V || #c_var{name=V} <- Vs2], Sub1),
{Vs2,As1,
- foldl(fun ({V,S}, Sub) -> sub_set_name(V, S, Sub) end, Sub2, Ss)}.
+ foldl(fun ({V,S}, Sub) -> sub_set_name(V, S, Sub) end, Sub2, Ss)}.
let_substs_1(Vs, #c_values{es=As}, Sub) ->
let_subst_list(Vs, As, Sub);
@@ -1242,10 +1242,10 @@ is_subst(_) -> false.
%% to force renaming if variables in the scope occurs as pattern
%% variables.
-sub_new() -> #sub{v=orddict:new(),s=gb_trees:empty(),t=[]}.
+sub_new() -> #sub{v=orddict:new(),s=cerl_sets:new(),t=#{}}.
sub_new(#sub{}=Sub) ->
- Sub#sub{v=orddict:new(),t=[]}.
+ Sub#sub{v=orddict:new(),t=#{}}.
sub_new_preserve_types(#sub{}=Sub) ->
Sub#sub{v=orddict:new()}.
@@ -1262,16 +1262,16 @@ sub_set_var(#c_var{name=V}, Val, Sub) ->
sub_set_name(V, Val, #sub{v=S,s=Scope,t=Tdb0}=Sub) ->
Tdb1 = kill_types(V, Tdb0),
Tdb = copy_type(V, Val, Tdb1),
- Sub#sub{v=orddict:store(V, Val, S),s=gb_sets:add(V, Scope),t=Tdb}.
+ Sub#sub{v=orddict:store(V, Val, S),s=cerl_sets:add_element(V, Scope),t=Tdb}.
sub_del_var(#c_var{name=V}, #sub{v=S,s=Scope,t=Tdb}=Sub) ->
%% Profiling shows that for programs with many record operations,
%% sub_del_var/2 is a bottleneck. Since the scope contains all
%% variables that are live, we know that V cannot be present in S
%% if it is not in the scope.
- case gb_sets:is_member(V, Scope) of
+ case cerl_sets:is_element(V, Scope) of
false ->
- Sub#sub{s=gb_sets:insert(V, Scope)};
+ Sub#sub{s=cerl_sets:add_element(V, Scope)};
true ->
Sub#sub{v=orddict:erase(V, S),t=kill_types(V, Tdb)}
end.
@@ -1282,12 +1282,12 @@ sub_subst_var(#c_var{name=V}, Val, #sub{v=S0}) ->
sub_add_scope(Vs, #sub{s=Scope0}=Sub) ->
Scope = foldl(fun(V, S) when is_integer(V); is_atom(V) ->
- gb_sets:add(V, S)
+ cerl_sets:add_element(V, S)
end, Scope0, Vs),
Sub#sub{s=Scope}.
sub_subst_scope(#sub{v=S0,s=Scope}=Sub) ->
- S = [{-1,#c_var{name=Sv}} || Sv <- gb_sets:to_list(Scope)]++S0,
+ S = [{-1,#c_var{name=Sv}} || Sv <- cerl_sets:to_list(Scope)]++S0,
Sub#sub{v=S}.
sub_is_val(#c_var{name=V}, #sub{v=S,s=Scope}) ->
@@ -1295,7 +1295,7 @@ sub_is_val(#c_var{name=V}, #sub{v=S,s=Scope}) ->
%% became the new bottleneck. Since the scope contains all
%% live variables, a variable V can only be the target for
%% a substitution if it is in the scope.
- gb_sets:is_member(V, Scope) andalso v_is_value(V, S).
+ cerl_sets:is_element(V, Scope) andalso v_is_value(V, S).
v_is_value(Var, [{_,#c_var{name=Var}}|_]) -> true;
v_is_value(Var, [_|T]) -> v_is_value(Var, T);
@@ -1760,8 +1760,9 @@ case_opt_compiler_generated(Core) ->
%% return Expr0 unchanged.
%%
case_expand_var(E, #sub{t=Tdb}) ->
- case orddict:find(cerl:var_name(E), Tdb) of
- {ok,T0} ->
+ Key = cerl:var_name(E),
+ case Tdb of
+ #{Key:=T0} ->
case cerl:is_c_tuple(T0) of
false ->
E;
@@ -1785,7 +1786,7 @@ case_expand_var(E, #sub{t=Tdb}) ->
E
end
end;
- error ->
+ _ ->
E
end.
@@ -2147,7 +2148,7 @@ is_bool_expr_list([], _) -> true.
%% functions, or is_record/2).
%%
is_safe_bool_expr(Core, Sub) ->
- is_safe_bool_expr_1(Core, Sub, gb_sets:empty()).
+ is_safe_bool_expr_1(Core, Sub, cerl_sets:new()).
is_safe_bool_expr_1(#c_call{module=#c_literal{val=erlang},
name=#c_literal{val=is_record},
@@ -2193,7 +2194,7 @@ is_safe_bool_expr_1(#c_let{vars=Vars,arg=Arg,body=B}, Sub, BoolVars) ->
true ->
case {is_safe_bool_expr_1(Arg, Sub, BoolVars),Vars} of
{true,[#c_var{name=V}]} ->
- is_safe_bool_expr_1(B, Sub, gb_sets:add(V, BoolVars));
+ is_safe_bool_expr_1(B, Sub, cerl_sets:add_element(V, BoolVars));
{false,_} ->
is_safe_bool_expr_1(B, Sub, BoolVars)
end;
@@ -2202,7 +2203,7 @@ is_safe_bool_expr_1(#c_let{vars=Vars,arg=Arg,body=B}, Sub, BoolVars) ->
is_safe_bool_expr_1(#c_literal{val=Val}, _Sub, _) ->
is_boolean(Val);
is_safe_bool_expr_1(#c_var{name=V}, _Sub, BoolVars) ->
- gb_sets:is_element(V, BoolVars);
+ cerl_sets:is_element(V, BoolVars);
is_safe_bool_expr_1(_, _, _) -> false.
is_safe_bool_expr_list([C|Cs], Sub, BoolVars) ->
@@ -2236,7 +2237,7 @@ move_let_into_expr(#c_let{vars=InnerVs0,body=InnerBody0}=Inner,
%% in <InnerBody>
%%
Arg = body(Arg0, Sub0),
- ScopeSub0 = sub_subst_scope(Sub0#sub{t=[]}),
+ ScopeSub0 = sub_subst_scope(Sub0#sub{t=#{}}),
{OuterVs,ScopeSub} = pattern_list(OuterVs0, ScopeSub0),
OuterBody = body(OuterBody0, ScopeSub),
@@ -2275,15 +2276,15 @@ move_let_into_expr(#c_let{vars=Lvs0,body=Lbody0}=Let,
CaVars0 = Ca0#c_clause.pats,
G0 = Ca0#c_clause.guard,
B0 = Ca0#c_clause.body,
- ScopeSub0 = sub_subst_scope(Sub0#sub{t=[]}),
+ ScopeSub0 = sub_subst_scope(Sub0#sub{t=#{}}),
{CaVars,ScopeSub} = pattern_list(CaVars0, ScopeSub0),
G = guard(G0, ScopeSub),
B1 = body(B0, ScopeSub),
{Lvs,B2,Sub1} = let_substs(Lvs0, B1, Sub0),
- Sub2 = Sub1#sub{s=gb_sets:union(ScopeSub#sub.s,
- Sub1#sub.s)},
+ Sub2 = Sub1#sub{s=cerl_sets:union(ScopeSub#sub.s,
+ Sub1#sub.s)},
Lbody = body(Lbody0, Sub2),
B = Let#c_let{vars=Lvs,arg=core_lib:make_values(B2),body=Lbody},
@@ -2574,7 +2575,7 @@ move_case_into_arg(#c_case{arg=#c_let{vars=OuterVars0,arg=OuterArg,
%% let <OuterVars> = <OuterArg>
%% in case <InnerArg> of <InnerClauses> end
%%
- ScopeSub0 = sub_subst_scope(Sub#sub{t=[]}),
+ ScopeSub0 = sub_subst_scope(Sub#sub{t=#{}}),
{OuterVars,ScopeSub} = pattern_list(OuterVars0, ScopeSub0),
InnerArg = body(InnerArg0, ScopeSub),
Outer#c_let{vars=OuterVars,arg=OuterArg,
@@ -2603,7 +2604,7 @@ move_case_into_arg(#c_case{arg=#c_case{arg=OuterArg,
%% <OuterCb>
%% end
%%
- ScopeSub0 = sub_subst_scope(Sub#sub{t=[]}),
+ ScopeSub0 = sub_subst_scope(Sub#sub{t=#{}}),
{OuterPats,ScopeSub} = pattern_list(OuterPats0, ScopeSub0),
OuterGuard = guard(OuterGuard0, ScopeSub),
InnerArg = body(InnerArg0, ScopeSub),
@@ -2688,9 +2689,9 @@ is_any_var_used([], _) -> false.
-spec get_type(cerl:cerl(), #sub{}) -> type_info() | 'none'.
get_type(#c_var{name=V}, #sub{t=Tdb}) ->
- case orddict:find(V, Tdb) of
- {ok,Type} -> Type;
- error -> none
+ case Tdb of
+ #{V:=Type} -> Type;
+ _ -> none
end;
get_type(C, _) ->
case cerl:type(C) of
@@ -2805,35 +2806,38 @@ update_types_1(#c_var{name=V,anno=Anno}, Pat, Types) ->
update_types_1(_, _, Types) -> Types.
update_types_2(V, [#c_tuple{}=P], Types) ->
- orddict:store(V, P, Types);
+ Types#{V=>P};
update_types_2(V, [#c_literal{val=Bool}], Types) when is_boolean(Bool) ->
- orddict:store(V, bool, Types);
+ Types#{V=>bool};
update_types_2(V, [Type], Types) when is_atom(Type) ->
- orddict:store(V, Type, Types);
+ Types#{V=>Type};
update_types_2(_, _, Types) -> Types.
%% kill_types(V, Tdb) -> Tdb'
%% Kill any entries that references the variable,
%% either in the key or in the value.
-kill_types(V, [{V,_}|Tdb]) ->
- kill_types(V, Tdb);
-kill_types(V, [{_,#c_tuple{}=Tuple}=Entry|Tdb]) ->
+kill_types(V, Tdb) ->
+ maps:from_list(kill_types2(V,maps:to_list(Tdb))).
+
+kill_types2(V, [{V,_}|Tdb]) ->
+ kill_types2(V, Tdb);
+kill_types2(V, [{_,#c_tuple{}=Tuple}=Entry|Tdb]) ->
case core_lib:is_var_used(V, Tuple) of
- false -> [Entry|kill_types(V, Tdb)];
- true -> kill_types(V, Tdb)
+ false -> [Entry|kill_types2(V, Tdb)];
+ true -> kill_types2(V, Tdb)
end;
-kill_types(V, [{_,Atom}=Entry|Tdb]) when is_atom(Atom) ->
- [Entry|kill_types(V, Tdb)];
-kill_types(_, []) -> [].
+kill_types2(V, [{_,Atom}=Entry|Tdb]) when is_atom(Atom) ->
+ [Entry|kill_types2(V, Tdb)];
+kill_types2(_, []) -> [].
%% copy_type(DestVar, SrcVar, Tdb) -> Tdb'
%% If the SrcVar has a type, assign it to DestVar.
%%
copy_type(V, #c_var{name=Src}, Tdb) ->
- case orddict:find(Src, Tdb) of
- {ok,Type} -> orddict:store(V, Type, Tdb);
- error -> Tdb
+ case Tdb of
+ #{Src:=Type} -> Tdb#{V=>Type};
+ _ -> Tdb
end;
copy_type(_, _, Tdb) -> Tdb.
@@ -3237,12 +3241,12 @@ format_error(bin_var_used_in_guard) ->
verify_scope(E, #sub{s=Scope}) ->
Free0 = cerl_trees:free_variables(E),
Free = [V || V <- Free0, not is_tuple(V)], %Ignore function names.
- case ordsets:is_subset(Free, gb_sets:to_list(Scope)) of
+ case ordsets:is_subset(Free, cerl_sets:to_list(Scope)) of
true -> true;
false ->
io:format("~p\n", [E]),
io:format("~p\n", [Free]),
- io:format("~p\n", [gb_sets:to_list(Scope)]),
+ io:format("~p\n", [cerl_sets:to_list(Scope)]),
false
end.
-endif.
diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl
index aa2ebc0f85..c9b1a45cfc 100644
--- a/lib/compiler/src/v3_codegen.erl
+++ b/lib/compiler/src/v3_codegen.erl
@@ -43,7 +43,7 @@
-export([module/2]).
-import(lists, [member/2,keymember/3,keysort/2,keydelete/3,
- append/1,map/2,flatmap/2,filter/2,foldl/3,foldr/3,mapfoldl/3,
+ append/1,flatmap/2,filter/2,foldl/3,foldr/3,mapfoldl/3,
sort/1,reverse/1,reverse/2]).
-import(v3_life, [vdb_find/2]).
@@ -57,8 +57,7 @@
break, %Break label
recv, %Receive label
is_top_block, %Boolean: top block or not
- functable=gb_trees:empty(), %Gb tree of local functions:
- % {{Name,Arity},Label}
+ functable=#{}, %Map of local functions: {Name,Arity}=>Label
in_catch=false, %Inside a catch or not.
need_frame, %Need a stack frame.
ultimate_failure %Label for ultimate match failure.
@@ -673,9 +672,7 @@ select_val_cg(Type, R, [Val, {f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) ->
[{test,select_type_test(Type),{f,Tf},[R]},
{test,is_eq_exact,{f,Vf},[R,{Type,Val}]}|Sis];
select_val_cg(Type, R, Vls0, Tf, Vf, Sis) ->
- Vls1 = map(fun ({f,_Lbl} = F) -> F;
- (Value) -> {Type,Value}
- end, Vls0),
+ Vls1 = [case Value of {f,_Lbl} -> Value; _ -> {Type,Value} end || Value <- Vls0],
[{test,select_type_test(Type),{f,Tf},[R]}, {select_val,R,{f,Vf},{list,Vls1}}|Sis].
select_type_test(integer) -> is_integer;
@@ -1080,7 +1077,7 @@ protected_cg(Ts, Rs, _Fail, I, Vdb, Bef, St0) ->
St2#cg{bfail=Pfail}),
%%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{Rs,I,Vdb,Aft}]),
%% Set return values to false.
- Mis = map(fun ({var,V}) -> {move,{atom,false},fetch_var(V, Aft)} end, Rs),
+ Mis = [{move,{atom,false},fetch_var(V,Aft)}||{var,V} <- Rs],
{Tis ++ [{jump,{f,Psucc}},
{label,Pfail}] ++ Mis ++ [{label,Psucc}],
Aft,St3#cg{bfail=St0#cg.bfail}}.
@@ -1263,13 +1260,12 @@ enter_line(_, _, _) ->
local_func_label(Name, Arity, St) ->
local_func_label({Name,Arity}, St).
-local_func_label(Key, #cg{functable=Tab}=St0) ->
- case gb_trees:lookup(Key, Tab) of
- {value,Label} ->
- {Label,St0};
- none ->
+local_func_label(Key, #cg{functable=Map}=St0) ->
+ case Map of
+ #{Key := Label} -> {Label,St0};
+ _ ->
{Label,St} = new_label(St0),
- {Label,St#cg{functable=gb_trees:insert(Key, Label, Tab)}}
+ {Label,St#cg{functable=Map#{Key => Label}}}
end.
%% need_stack_frame(State) -> State'
@@ -1992,25 +1988,28 @@ clear_dead(Sr, Until, Vdb) ->
stk=clear_dead_stk(Sr#sr.stk, Until, Vdb)}.
clear_dead_reg(Sr, Until, Vdb) ->
- Reg = map(fun ({_I,V} = IV) ->
- case vdb_find(V, Vdb) of
- {V,_,L} when L > Until -> IV;
- _ -> free %Remove anything else
- end;
- ({reserved,_I,_V} = Reserved) -> Reserved;
- (free) -> free
- end, Sr#sr.reg),
+ Reg = [case R of
+ {_I,V} = IV ->
+ case vdb_find(V, Vdb) of
+ {V,_,L} when L > Until -> IV;
+ _ -> free %Remove anything else
+ end;
+ {reserved,_I,_V} = Reserved -> Reserved;
+ free -> free
+ end || R <- Sr#sr.reg],
reserve(Sr#sr.res, Reg, Sr#sr.stk).
clear_dead_stk(Stk, Until, Vdb) ->
- map(fun ({V} = T) ->
- case vdb_find(V, Vdb) of
- {V,_,L} when L > Until -> T;
- _ -> dead %Remove anything else
- end;
- (free) -> free;
- (dead) -> dead
- end, Stk).
+ [case S of
+ {V} = T ->
+ case vdb_find(V, Vdb) of
+ {V,_,L} when L > Until -> T;
+ _ -> dead %Remove anything else
+ end;
+ free -> free;
+ dead -> dead
+ end || S <- Stk].
+
%% sr_merge(Sr1, Sr2) -> Sr.
%% Merge two stack/register states keeping the longest of both stack
diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl
index 7dff58582e..c21b2a1505 100644
--- a/lib/compiler/src/v3_kernel.erl
+++ b/lib/compiler/src/v3_kernel.erl
@@ -114,7 +114,7 @@ copy_anno(Kdst, Ksrc) ->
ff, %Current function
vcount=0, %Variable counter
fcount=0, %Fun counter
- ds=[], %Defined variables
+ ds=cerl_sets:new() :: cerl_sets:set(), %Defined variables
funs=[], %Fun functions
free=[], %Free variables
ws=[] :: [warning()], %Warnings.
@@ -148,7 +148,7 @@ include_attribute(_) -> true.
function({#c_var{name={F,Arity}=FA},Body}, St0) ->
try
- St1 = St0#kern{func=FA,ff=undefined,vcount=0,fcount=0,ds=sets:new()},
+ St1 = St0#kern{func=FA,ff=undefined,vcount=0,fcount=0,ds=cerl_sets:new()},
{#ifun{anno=Ab,vars=Kvs,body=B0},[],St2} = expr(Body, new_sub(), St1),
{B1,_,St3} = ubody(B0, return, St2),
%%B1 = B0, St3 = St2, %Null second pass
@@ -715,15 +715,15 @@ force_variable(Ke, St0) ->
%% handling.
pattern(#c_var{anno=A,name=V}, _Isub, Osub, St0) ->
- case sets:is_element(V, St0#kern.ds) of
+ case cerl_sets:is_element(V, St0#kern.ds) of
true ->
{New,St1} = new_var_name(St0),
{#k_var{anno=A,name=New},
set_vsub(V, New, Osub),
- St1#kern{ds=sets:add_element(New, St1#kern.ds)}};
+ St1#kern{ds=cerl_sets:add_element(New, St1#kern.ds)}};
false ->
{#k_var{anno=A,name=V},Osub,
- St0#kern{ds=sets:add_element(V, St0#kern.ds)}}
+ St0#kern{ds=cerl_sets:add_element(V, St0#kern.ds)}}
end;
pattern(#c_literal{anno=A,val=Val}, _Isub, Osub, St) ->
{#k_literal{anno=A,val=Val},Osub,St};
@@ -897,7 +897,7 @@ new_vars(0, St, Vs) -> {Vs,St}.
make_vars(Vs) -> [ #k_var{name=V} || V <- Vs ].
add_var_def(V, St) ->
- St#kern{ds=sets:add_element(V#k_var.name, St#kern.ds)}.
+ St#kern{ds=cerl_sets:add_element(V#k_var.name, St#kern.ds)}.
%%add_vars_def(Vs, St) ->
%% Ds = foldl(fun (#k_var{name=V}, Ds) -> add_element(V, Ds) end,
diff --git a/lib/compiler/src/v3_life.erl b/lib/compiler/src/v3_life.erl
index 4b1f1c3f71..ee0565efb6 100644
--- a/lib/compiler/src/v3_life.erl
+++ b/lib/compiler/src/v3_life.erl
@@ -411,7 +411,7 @@ is_gc_bif(Bif, Arity) ->
%% must be sorted.
init_vars(Vs) ->
- sort([{V,0,0} || {var,V} <- Vs]).
+ vdb_new(Vs).
new_vars([], _, Vdb) -> Vdb;
new_vars([V], I, Vdb) -> vdb_store_new(V, {V,I,I}, Vdb);
@@ -430,6 +430,16 @@ use_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I).
add_var(V, F, L, Vdb) ->
vdb_store_new(V, {V,F,L}, Vdb).
+%% is_in_guard() -> true|false.
+
+is_in_guard() ->
+ get(guard_refc) > 0.
+
+%% vdb
+
+vdb_new(Vs) ->
+ sort([{V,0,0} || {var,V} <- Vs]).
+
vdb_find(V, Vdb) ->
case lists:keyfind(V, 1, Vdb) of
false -> error;
@@ -471,8 +481,3 @@ vdb_sub(Min, Max, Vdb) ->
[ if L >= Max -> {V,F,locked};
true -> Vd
end || {V,F,L}=Vd <- Vdb, F < Min, L >= Min ].
-
-%% is_in_guard() -> true|false.
-
-is_in_guard() ->
- get(guard_refc) > 0.
diff --git a/lib/compiler/vsn.mk b/lib/compiler/vsn.mk
index 05e682c893..69f71ba5dd 100644
--- a/lib/compiler/vsn.mk
+++ b/lib/compiler/vsn.mk
@@ -1 +1 @@
-COMPILER_VSN = 5.0.4
+COMPILER_VSN = 6.0
diff --git a/lib/cosNotification/src/cosNotification.app.src b/lib/cosNotification/src/cosNotification.app.src
index 09bf8f01fc..52ce164d46 100644
--- a/lib/cosNotification/src/cosNotification.app.src
+++ b/lib/cosNotification/src/cosNotification.app.src
@@ -117,6 +117,6 @@
{applications, [orber, stdlib, kernel]},
{env, []},
{mod, {cosNotificationApp, []}},
- {runtime_dependencies, ["stdlib-2.0","orber-3.6.27","kernel-3.0","erts-7.0",
+ {runtime_dependencies, ["stdlib-2.5","orber-3.6.27","kernel-3.0","erts-7.0",
"cosTime-1.1.14","cosEvent-2.1.15"]}
]}.
diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl
index 72944eea8e..ff7af1f2c1 100644
--- a/lib/crypto/test/crypto_SUITE.erl
+++ b/lib/crypto/test/crypto_SUITE.erl
@@ -1884,8 +1884,9 @@ dss_params() ->
18320614775012672475365915366944922415598782131828709277168615511695849821411624805195787607930033958243224786899641459701930253094446221381818858674389863050420226114787005820357372837321561754462061849169568607689530279303056075793886577588606958623645901271866346406773590024901668622321064384483571751669].
ec_key_named() ->
- {D2_pub, D2_priv} = crypto:generate_key(ecdh, sect113r2),
- {[D2_priv, sect113r2], [D2_pub, sect113r2]}.
+ Curve = secp112r2,
+ {D2_pub, D2_priv} = crypto:generate_key(ecdh, Curve),
+ {[D2_priv, Curve], [D2_pub, Curve]}.
ec_msg() ->
<<99,234,6,64,190,237,201,99,80,248,58,40,70,45,149,218,5,246,242,63>>.
diff --git a/lib/crypto/test/old_crypto_SUITE.erl b/lib/crypto/test/old_crypto_SUITE.erl
index 040edbf092..80306927c5 100644
--- a/lib/crypto/test/old_crypto_SUITE.erl
+++ b/lib/crypto/test/old_crypto_SUITE.erl
@@ -1887,9 +1887,9 @@ ec(Config) when is_list(Config) ->
ec_do() ->
%% test for a name curve
- {D2_pub, D2_priv} = crypto:generate_key(ecdh, sect113r2),
- PrivECDH = [D2_priv, sect113r2],
- PubECDH = [D2_pub, sect113r2],
+ {D2_pub, D2_priv} = crypto:generate_key(ecdh, secp112r2),
+ PrivECDH = [D2_priv, secp112r2],
+ PubECDH = [D2_pub, secp112r2],
%%TODO: find a published test case for a EC key
%% test for a full specified curve and public key,
diff --git a/lib/crypto/vsn.mk b/lib/crypto/vsn.mk
index 8489b59562..55b1b3e8c4 100644
--- a/lib/crypto/vsn.mk
+++ b/lib/crypto/vsn.mk
@@ -1 +1 @@
-CRYPTO_VSN = 3.5
+CRYPTO_VSN = 3.6
diff --git a/lib/debugger/src/debugger.app.src b/lib/debugger/src/debugger.app.src
index f102385d39..a013c5c11f 100644
--- a/lib/debugger/src/debugger.app.src
+++ b/lib/debugger/src/debugger.app.src
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1997-2013. All Rights Reserved.
+%% Copyright Ericsson AB 1997-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -47,5 +47,5 @@
]},
{registered, [dbg_iserver, dbg_wx_mon, dbg_wx_winman]},
{applications, [kernel, stdlib]},
- {runtime_dependencies, ["wx-1.2","stdlib-2.0","kernel-3.0","erts-6.0",
+ {runtime_dependencies, ["wx-1.2","stdlib-2.5","kernel-3.0","erts-6.0",
"compiler-5.0"]}]}.
diff --git a/lib/debugger/test/map_SUITE.erl b/lib/debugger/test/map_SUITE.erl
index 12fdd184b8..74847e161f 100644
--- a/lib/debugger/test/map_SUITE.erl
+++ b/lib/debugger/test/map_SUITE.erl
@@ -1308,7 +1308,7 @@ t_guard_receive(Config) when is_list(Config) ->
done = call(Pid, done),
ok.
--define(t_guard_receive_large_procs, 150).
+-define(t_guard_receive_large_procs, 50).
t_guard_receive_large(Config) when is_list(Config) ->
M = lists:foldl(fun(_,#{procs := Ps } = M) ->
@@ -1326,7 +1326,7 @@ guard_receive_large_loop(M) ->
receive
#{pid := Pid, msg := hello} ->
case M of
- #{done := Count, procs := #{Pid := 150}} ->
+ #{done := Count, procs := #{Pid := 15}} ->
Pid ! {self(), done},
guard_receive_large_loop(M#{done := Count + 1});
#{procs := #{Pid := Count} = Ps} ->
diff --git a/lib/debugger/vsn.mk b/lib/debugger/vsn.mk
index b82f0f4e37..b6fd4e8e44 100644
--- a/lib/debugger/vsn.mk
+++ b/lib/debugger/vsn.mk
@@ -1 +1 @@
-DEBUGGER_VSN = 4.0.3
+DEBUGGER_VSN = 4.1
diff --git a/lib/dialyzer/src/dialyzer.app.src b/lib/dialyzer/src/dialyzer.app.src
index 7b2e1d4a9d..b6b9173a84 100644
--- a/lib/dialyzer/src/dialyzer.app.src
+++ b/lib/dialyzer/src/dialyzer.app.src
@@ -2,7 +2,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2006-2014. All Rights Reserved.
+%% Copyright Ericsson AB 2006-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -45,6 +45,6 @@
{registered, []},
{applications, [compiler, gs, hipe, kernel, stdlib, wx]},
{env, []},
- {runtime_dependencies, ["wx-1.2","syntax_tools-1.6.14","stdlib-2.0",
+ {runtime_dependencies, ["wx-1.2","syntax_tools-1.6.14","stdlib-2.5",
"kernel-3.0","hipe-3.10.3","erts-7.0",
"compiler-5.0"]}]}.
diff --git a/lib/dialyzer/vsn.mk b/lib/dialyzer/vsn.mk
index 527afaf4ef..48e0830109 100644
--- a/lib/dialyzer/vsn.mk
+++ b/lib/dialyzer/vsn.mk
@@ -1 +1 @@
-DIALYZER_VSN = 2.7.4
+DIALYZER_VSN = 2.8
diff --git a/lib/edoc/src/edoc.app.src b/lib/edoc/src/edoc.app.src
index 9e1155d3e8..e4b9040c78 100644
--- a/lib/edoc/src/edoc.app.src
+++ b/lib/edoc/src/edoc.app.src
@@ -23,5 +23,5 @@
{registered,[]},
{applications, [compiler,kernel,stdlib,syntax_tools]},
{env, []},
- {runtime_dependencies, ["xmerl-1.3.7","syntax_tools-1.6.14","stdlib-2.0",
+ {runtime_dependencies, ["xmerl-1.3.7","syntax_tools-1.6.14","stdlib-2.5",
"kernel-3.0","inets-5.10","erts-6.0"]}]}.
diff --git a/lib/edoc/vsn.mk b/lib/edoc/vsn.mk
index 24cfbf16d5..49a73331c6 100644
--- a/lib/edoc/vsn.mk
+++ b/lib/edoc/vsn.mk
@@ -1 +1 @@
-EDOC_VSN = 0.7.16
+EDOC_VSN = 0.7.17
diff --git a/lib/erl_docgen/src/erl_docgen.app.src b/lib/erl_docgen/src/erl_docgen.app.src
index e2830b2692..d63d880d89 100644
--- a/lib/erl_docgen/src/erl_docgen.app.src
+++ b/lib/erl_docgen/src/erl_docgen.app.src
@@ -9,6 +9,6 @@
{registered,[]},
{applications, [kernel,stdlib]},
{env, []},
- {runtime_dependencies, ["xmerl-1.3.7","stdlib-2.0","edoc-0.7.13","erts-6.0"]}
+ {runtime_dependencies, ["xmerl-1.3.7","stdlib-2.5","edoc-0.7.13","erts-6.0"]}
]
}.
diff --git a/lib/eunit/src/eunit.app.src b/lib/eunit/src/eunit.app.src
index 7a3978e200..b4ff6c9242 100644
--- a/lib/eunit/src/eunit.app.src
+++ b/lib/eunit/src/eunit.app.src
@@ -19,4 +19,4 @@
{registered,[]},
{applications, [kernel,stdlib]},
{env, []},
- {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]}]}.
+ {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]}]}.
diff --git a/lib/eunit/vsn.mk b/lib/eunit/vsn.mk
index dca8b3ece0..b551ee6eb6 100644
--- a/lib/eunit/vsn.mk
+++ b/lib/eunit/vsn.mk
@@ -1 +1 @@
-EUNIT_VSN = 2.2.9
+EUNIT_VSN = 2.3
diff --git a/lib/hipe/main/hipe.app.src b/lib/hipe/main/hipe.app.src
index 22ea71b4e6..7b6d9e30e3 100644
--- a/lib/hipe/main/hipe.app.src
+++ b/lib/hipe/main/hipe.app.src
@@ -2,7 +2,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2002-2012. All Rights Reserved.
+%% Copyright Ericsson AB 2002-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -223,5 +223,5 @@
{registered,[]},
{applications, [kernel,stdlib]},
{env, []},
- {runtime_dependencies, ["syntax_tools-1.6.14","stdlib-2.0","kernel-3.0",
+ {runtime_dependencies, ["syntax_tools-1.6.14","stdlib-2.5","kernel-3.0",
"erts-7.0","compiler-5.0"]}]}.
diff --git a/lib/hipe/vsn.mk b/lib/hipe/vsn.mk
index 60b4e0559b..e507ae933f 100644
--- a/lib/hipe/vsn.mk
+++ b/lib/hipe/vsn.mk
@@ -1 +1 @@
-HIPE_VSN = 3.11.3
+HIPE_VSN = 3.12
diff --git a/lib/inets/src/http_client/httpc_handler.erl b/lib/inets/src/http_client/httpc_handler.erl
index 8f2f11ce8e..f4f0c37570 100644
--- a/lib/inets/src/http_client/httpc_handler.erl
+++ b/lib/inets/src/http_client/httpc_handler.erl
@@ -87,7 +87,7 @@
%% block the httpc manager process in odd cases such as trying to call
%% a server that does not exist. (See OTP-6735) The only API function
%% sending messages to the handler process that can be called before
-%% init has compleated is cancel and that is not a problem! (Send and
+%% init has completed is cancel and that is not a problem! (Send and
%% stream will not be called before the first request has been sent and
%% the reply or part of it has arrived.)
%%--------------------------------------------------------------------
@@ -392,7 +392,7 @@ handle_call(info, _, State) ->
%% When the request in process has been canceled the handler process is
%% stopped and the pipelined requests will be reissued or remaining
%% requests will be sent on a new connection. This is is
-%% based on the assumption that it is proably cheaper to reissue the
+%% based on the assumption that it is probably cheaper to reissue the
%% requests than to wait for a potentiall large response that we then
%% only throw away. This of course is not always true maybe we could
%% do something smarter here?! If the request canceled is not
@@ -1345,7 +1345,7 @@ handle_empty_queue(Session, ProfileName, TimeOut, State) ->
%% closed by the server, the client may want to close it.
NewState = activate_queue_timeout(TimeOut, State),
update_session(ProfileName, Session, #session.queue_length, 0),
- %% Note mfa will be initilized when a new request
+ %% Note mfa will be initialized when a new request
%% arrives.
{noreply,
NewState#state{request = undefined,
diff --git a/lib/inets/vsn.mk b/lib/inets/vsn.mk
index ecb84e447c..f52347e39e 100644
--- a/lib/inets/vsn.mk
+++ b/lib/inets/vsn.mk
@@ -2,7 +2,7 @@
# %CopyrightBegin%
#
-# Copyright Ericsson AB 2001-2014. All Rights Reserved.
+# Copyright Ericsson AB 2001-2015. All Rights Reserved.
#
# The contents of this file are subject to the Erlang Public License,
# Version 1.1, (the "License"); you may not use this file except in
@@ -18,6 +18,6 @@
# %CopyrightEnd%
APPLICATION = inets
-INETS_VSN = 5.10.8
+INETS_VSN = 6.0
PRE_VSN =
APP_VSN = "$(APPLICATION)-$(INETS_VSN)$(PRE_VSN)"
diff --git a/lib/kernel/src/code.erl b/lib/kernel/src/code.erl
index 5cc38325b1..65045666ec 100644
--- a/lib/kernel/src/code.erl
+++ b/lib/kernel/src/code.erl
@@ -560,12 +560,12 @@ load_native_code_for_all_loaded() ->
try hipe_unified_loader:chunk_name(Architecture) of
ChunkTag ->
Loaded = all_loaded(),
- spawn(fun() -> load_all_native(Loaded, ChunkTag) end)
+ _ = spawn(fun() -> load_all_native(Loaded, ChunkTag) end),
+ ok
catch
_:_ ->
ok
- end,
- ok.
+ end.
load_all_native(Loaded, ChunkTag) ->
catch load_all_native_1(Loaded, ChunkTag).
@@ -582,7 +582,8 @@ load_all_native_1([{Mod,BeamFilename}|T], ChunkTag) ->
undefined ->
ok;
NativeCode when is_binary(NativeCode) ->
- load_native_partial(Mod, NativeCode)
+ _ = load_native_partial(Mod, NativeCode),
+ ok
end;
true -> ok
end,
diff --git a/lib/kernel/src/inet_parse.erl b/lib/kernel/src/inet_parse.erl
index a88c94a453..a694642b19 100644
--- a/lib/kernel/src/inet_parse.erl
+++ b/lib/kernel/src/inet_parse.erl
@@ -675,28 +675,22 @@ ipv6_addr_done(Ar, Br, N) ->
ipv6_addr_done(Ar) ->
list_to_tuple(lists:reverse(Ar)).
-%% Collect Hex digits
-hex(Cs) -> hex(Cs, []).
-%%
-hex([C|Cs], R) when C >= $0, C =< $9 ->
- hex(Cs, [C|R]);
-hex([C|Cs], R) when C >= $a, C =< $f ->
- hex(Cs, [C|R]);
-hex([C|Cs], R) when C >= $A, C =< $F ->
- hex(Cs, [C|R]);
-hex(Cs, [_|_]=R) when is_list(Cs) ->
+%% Collect 1-4 Hex digits
+hex(Cs) -> hex(Cs, [], 4).
+%%
+hex([C|Cs], R, N) when C >= $0, C =< $9, N > 0 ->
+ hex(Cs, [C|R], N-1);
+hex([C|Cs], R, N) when C >= $a, C =< $f, N > 0 ->
+ hex(Cs, [C|R], N-1);
+hex([C|Cs], R, N) when C >= $A, C =< $F, N > 0 ->
+ hex(Cs, [C|R], N-1);
+hex(Cs, [_|_]=R, _) when is_list(Cs) ->
{lists:reverse(R),Cs};
-hex(_, _) ->
+hex(_, _, _) ->
erlang:error(badarg).
%% Hex string to integer
-hex_to_int(Cs0) ->
- case strip0(Cs0) of
- Cs when length(Cs) =< 4 ->
- erlang:list_to_integer("0"++Cs, 16);
- _ ->
- erlang:error(badarg)
- end.
+hex_to_int(Cs) -> erlang:list_to_integer(Cs, 16).
%% Dup onto head of existing list
dup(0, _, L) ->
diff --git a/lib/kernel/src/kernel.appup.src b/lib/kernel/src/kernel.appup.src
index 1bae762bed..5d3836bad7 100644
--- a/lib/kernel/src/kernel.appup.src
+++ b/lib/kernel/src/kernel.appup.src
@@ -1,7 +1,7 @@
%% -*- erlang -*-
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1999-2014. All Rights Reserved.
+%% Copyright Ericsson AB 1999-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -17,7 +17,7 @@
%% %CopyrightEnd%
{"%VSN%",
%% Up from - max one major revision back
- [{<<"3\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-17
+ [{<<"3\\.[0-2](\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-17
%% Down to - max one major revision back
- [{<<"3\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-17
+ [{<<"3\\.[0-2](\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-17
}.
diff --git a/lib/kernel/src/user_drv.erl b/lib/kernel/src/user_drv.erl
index 380c685869..d3deca3a20 100644
--- a/lib/kernel/src/user_drv.erl
+++ b/lib/kernel/src/user_drv.erl
@@ -135,7 +135,7 @@ server1(Iport, Oport, Shell) ->
Iport, Oport),
%% Enter the server loop.
- server_loop(Iport, Oport, Curr, User, Gr, queue:new()).
+ server_loop(Iport, Oport, Curr, User, Gr, {false, queue:new()}).
rem_sh_opts(Node) ->
[{expand_fun,fun(B)-> rpc:call(Node,edlin_expand,expand,[B]) end}].
@@ -165,7 +165,7 @@ server_loop(Iport, Oport, User, Gr, IOQueue) ->
put(current_group, Curr),
server_loop(Iport, Oport, Curr, User, Gr, IOQueue).
-server_loop(Iport, Oport, Curr, User, Gr, IOQueue) ->
+server_loop(Iport, Oport, Curr, User, Gr, {Resp, IOQ} = IOQueue) ->
receive
{Iport,{data,Bs}} ->
BsBin = list_to_binary(Bs),
@@ -182,9 +182,9 @@ server_loop(Iport, Oport, Curr, User, Gr, IOQueue) ->
{Oport,ok} ->
%% We get this ok from the port, in io_request we store
%% info about where to send reply at head of queue
- {{value,{Origin,Reply}},ReplyQ} = queue:out(IOQueue),
+ {Origin,Reply} = Resp,
Origin ! {reply,Reply},
- NewQ = handle_req(next, Iport, Oport, ReplyQ),
+ NewQ = handle_req(next, Iport, Oport, {false, IOQ}),
server_loop(Iport, Oport, Curr, User, Gr, NewQ);
{'EXIT',Iport,_R} ->
server_loop(Iport, Oport, Curr, User, Gr, IOQueue);
@@ -238,28 +238,30 @@ handle_req({Curr,get_unicode_state},Iport,_Oport,IOQueue) ->
handle_req({Curr,set_unicode_state, Bool},Iport,_Oport,IOQueue) ->
Curr ! {self(),set_unicode_state,set_unicode_state(Iport,Bool)},
IOQueue;
-handle_req(next,Iport,Oport,IOQueue) ->
- case queue:out(IOQueue) of
- {{value,Next},ExecQ} ->
- NewQ = handle_req(Next,Iport,Oport,queue:new()),
- queue:join(NewQ,ExecQ);
+handle_req(next,Iport,Oport,{false,IOQ}=IOQueue) ->
+ case queue:out(IOQ) of
{empty,_} ->
- IOQueue
- end;
-handle_req(Msg,Iport,Oport,IOQueue) ->
- case queue:peek(IOQueue) of
- empty ->
- {Origin,Req} = Msg,
+ IOQueue;
+ {{value,{Origin,Req}},ExecQ} ->
case io_request(Req, Iport, Oport) of
- ok -> IOQueue;
+ ok ->
+ handle_req(next,Iport,Oport,{false,ExecQ});
Reply ->
- %% Push reply info to front of queue
- queue:in_r({Origin,Reply},IOQueue)
- end;
- _Else ->
- %% All requests are queued when we have outstanding sync put_chars
- queue:in(Msg,IOQueue)
- end.
+ {{Origin,Reply}, ExecQ}
+ end
+ end;
+handle_req(Msg,Iport,Oport,{false,IOQ}=IOQueue) ->
+ empty = queue:peek(IOQ),
+ {Origin,Req} = Msg,
+ case io_request(Req, Iport, Oport) of
+ ok ->
+ IOQueue;
+ Reply ->
+ {{Origin,Reply}, IOQ}
+ end;
+handle_req(Msg,_Iport,_Oport,{Resp, IOQ}) ->
+ %% All requests are queued when we have outstanding sync put_chars
+ {Resp, queue:in(Msg,IOQ)}.
%% port_bytes(Bytes, InPort, OutPort, CurrentProcess, UserProcess, Group)
%% Check the Bytes from the port to see if it contains a ^G. If so,
diff --git a/lib/kernel/test/inet_SUITE.erl b/lib/kernel/test/inet_SUITE.erl
index 44a32fc1ec..c77de9316f 100644
--- a/lib/kernel/test/inet_SUITE.erl
+++ b/lib/kernel/test/inet_SUITE.erl
@@ -569,8 +569,11 @@ parse_address(Config) when is_list(Config) ->
"::-1",
"::g",
"f:f11::10100:2",
+ "f:f11::01100:2",
"::17000",
+ "::01700",
"10000::",
+ "01000::",
"::8:7:6:5:4:3:2:1",
"8:7:6:5:4:3:2:1::",
"8:7:6:5:4::3:2:1",
diff --git a/lib/kernel/vsn.mk b/lib/kernel/vsn.mk
index e1d447a465..c912da0091 100644
--- a/lib/kernel/vsn.mk
+++ b/lib/kernel/vsn.mk
@@ -1 +1 @@
-KERNEL_VSN = 3.2
+KERNEL_VSN = 4.0
diff --git a/lib/megaco/src/app/megaco.app.src b/lib/megaco/src/app/megaco.app.src
index 6ab85a1bbc..3720b1109e 100644
--- a/lib/megaco/src/app/megaco.app.src
+++ b/lib/megaco/src/app/megaco.app.src
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1999-2013. All Rights Reserved.
+%% Copyright Ericsson AB 1999-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -113,7 +113,7 @@
{applications, [stdlib, kernel]},
{env, []},
{mod, {megaco_sup, []}},
- {runtime_dependencies, ["stdlib-2.0","runtime_tools-1.8.14","kernel-3.0",
+ {runtime_dependencies, ["stdlib-2.5","runtime_tools-1.8.14","kernel-3.0",
"et-1.5","erts-6.0","debugger-4.0",
"asn1-3.0"]}
]}.
diff --git a/lib/megaco/src/app/megaco.appup.src b/lib/megaco/src/app/megaco.appup.src
index 92504e8e87..86ad09f639 100644
--- a/lib/megaco/src/app/megaco.appup.src
+++ b/lib/megaco/src/app/megaco.appup.src
@@ -2,7 +2,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2001-2014. All Rights Reserved.
+%% Copyright Ericsson AB 2001-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -183,11 +183,15 @@
%% |
%% v
%% 3.17.3
+%% |
+%% v
+%% 3.18
%%
%%
{"%VSN%",
[
+ {"3.17.3", []},
{"3.17.2", []},
{"3.17.1", [{restart_application,megaco}]},
{"3.17.0.3", [{restart_application,megaco}]},
@@ -202,6 +206,7 @@
}
],
[
+ {"3.17.3", []},
{"3.17.2", []},
{"3.17.1", [{restart_application,megaco}]},
{"3.17.0.3", [{restart_application,megaco}]},
diff --git a/lib/megaco/vsn.mk b/lib/megaco/vsn.mk
index 8687d622e9..ede36e3fe6 100644
--- a/lib/megaco/vsn.mk
+++ b/lib/megaco/vsn.mk
@@ -2,7 +2,7 @@
# %CopyrightBegin%
#
-# Copyright Ericsson AB 1997-2014. All Rights Reserved.
+# Copyright Ericsson AB 1997-2015. All Rights Reserved.
#
# The contents of this file are subject to the Erlang Public License,
# Version 1.1, (the "License"); you may not use this file except in
@@ -18,6 +18,6 @@
# %CopyrightEnd%
APPLICATION = megaco
-MEGACO_VSN = 3.17.3
+MEGACO_VSN = 3.18
PRE_VSN =
APP_VSN = "$(APPLICATION)-$(MEGACO_VSN)$(PRE_VSN)"
diff --git a/lib/mnesia/vsn.mk b/lib/mnesia/vsn.mk
index b23339e408..79dd495c4b 100644
--- a/lib/mnesia/vsn.mk
+++ b/lib/mnesia/vsn.mk
@@ -1 +1 @@
-MNESIA_VSN = 4.12.5
+MNESIA_VSN = 4.13
diff --git a/lib/observer/vsn.mk b/lib/observer/vsn.mk
index 10ed3bdfe5..7e7e32099b 100644
--- a/lib/observer/vsn.mk
+++ b/lib/observer/vsn.mk
@@ -1 +1 @@
-OBSERVER_VSN = 2.0.4
+OBSERVER_VSN = 2.1
diff --git a/lib/os_mon/vsn.mk b/lib/os_mon/vsn.mk
index 833e855e0e..7f2667e40a 100644
--- a/lib/os_mon/vsn.mk
+++ b/lib/os_mon/vsn.mk
@@ -1 +1 @@
-OS_MON_VSN = 2.3.1
+OS_MON_VSN = 2.4
diff --git a/lib/parsetools/src/parsetools.app.src b/lib/parsetools/src/parsetools.app.src
index 9eeb8fcc05..a7b258820a 100644
--- a/lib/parsetools/src/parsetools.app.src
+++ b/lib/parsetools/src/parsetools.app.src
@@ -12,7 +12,7 @@
{env, [{file_util_search_methods,[{"", ""}, {"ebin", "esrc"}, {"ebin", "src"}]}
]
},
- {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]}
+ {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]}
]
}.
diff --git a/lib/parsetools/vsn.mk b/lib/parsetools/vsn.mk
index dd9cc2991c..b99b3bb713 100644
--- a/lib/parsetools/vsn.mk
+++ b/lib/parsetools/vsn.mk
@@ -1 +1 @@
-PARSETOOLS_VSN = 2.0.12
+PARSETOOLS_VSN = 2.1
diff --git a/lib/sasl/vsn.mk b/lib/sasl/vsn.mk
index 4259a2d76c..8d1a043410 100644
--- a/lib/sasl/vsn.mk
+++ b/lib/sasl/vsn.mk
@@ -1 +1 @@
-SASL_VSN = 2.4.1
+SASL_VSN = 2.4.2
diff --git a/lib/snmp/src/app/snmp.app.src b/lib/snmp/src/app/snmp.app.src
index cbd292e4c3..a55bb389ba 100644
--- a/lib/snmp/src/app/snmp.app.src
+++ b/lib/snmp/src/app/snmp.app.src
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2013. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -137,5 +137,5 @@
%% before snmp.
{applications, [kernel, stdlib]},
{mod, {snmp_app, []}},
- {runtime_dependencies, ["stdlib-2.0","runtime_tools-1.8.14","mnesia-4.12",
+ {runtime_dependencies, ["stdlib-2.5","runtime_tools-1.8.14","mnesia-4.12",
"kernel-3.0","erts-6.0","crypto-3.3"]}]}.
diff --git a/lib/snmp/src/app/snmp.appup.src b/lib/snmp/src/app/snmp.appup.src
index 081163b368..a21ff863be 100644
--- a/lib/snmp/src/app/snmp.appup.src
+++ b/lib/snmp/src/app/snmp.appup.src
@@ -28,6 +28,8 @@
%% {update, snmpa_local_db, soft, soft_purge, soft_purge, []}
%% {add_module, snmpm_net_if_mt}
[
+ {"5.1.2", [ % Only runtime dependencies change
+ ]},
{"5.1.1", [{restart_application, snmp}]},
{"5.1", [ % Only compiler changes
]},
@@ -47,6 +49,8 @@
%% {remove, {snmpm_net_if_mt, soft_purge, soft_purge}}
[
+ {"5.1.2", [ % Only runtime dependencies change
+ ]},
{"5.1.1", [{restart_application, snmp}]},
{"5.1", [ % Only compiler changes
]},
diff --git a/lib/snmp/vsn.mk b/lib/snmp/vsn.mk
index 67adf0a34f..14da37a225 100644
--- a/lib/snmp/vsn.mk
+++ b/lib/snmp/vsn.mk
@@ -18,6 +18,6 @@
# %CopyrightEnd%
APPLICATION = snmp
-SNMP_VSN = 5.1.2
+SNMP_VSN = 5.2
PRE_VSN =
APP_VSN = "$(APPLICATION)-$(SNMP_VSN)$(PRE_VSN)"
diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml
index df13442fc6..cf58806aa8 100644
--- a/lib/ssh/doc/src/ssh.xml
+++ b/lib/ssh/doc/src/ssh.xml
@@ -35,13 +35,15 @@
<section>
<title>SSH</title>
-
+ <marker id="supported"/>
<list type="bulleted">
<item>For application dependencies see <seealso marker="SSH_app"> ssh(6)</seealso> </item>
<item>Supported SSH version is 2.0.</item>
+ <item>Supported public key algorithms: ssh-rsa and ssh-dss.</item>
<item>Supported MAC algorithms: hmac-sha2-256 and hmac-sha1.</item>
<item>Supported encryption algorithms: aes128-ctr, aes128-cb and 3des-cbc.</item>
<item>Supported key exchange algorithms: diffie-hellman-group1-sha1.</item>
+ <item>Supported compression algorithms: none, zlib, [email protected],</item>
<item>Supports unicode filenames if the emulator and the underlaying OS support it.
See section DESCRIPTION in the
<seealso marker="kernel:file">file</seealso> manual page in <c>kernel</c>
@@ -79,6 +81,18 @@
<seealso marker="ssh_channel">ssh_channel(3)</seealso></p></item>
<tag><c>channel_init_args() =</c></tag>
<item><p><c>list()</c></p></item>
+
+ <tag><c>algs_list() =</c></tag>
+ <item><p><c>list( alg_entry() )</c></p></item>
+
+ <tag><c>alg_entry() =</c></tag>
+ <item><p><c>{kex, simple_algs()} | {public_key, simple_algs()} | {cipher, double_algs()} | {mac, double_algs()} | {compression, double_algs()}</c></p></item>
+
+ <tag><c>simple_algs() =</c></tag>
+ <item><p><c>list( atom() )</c></p></item>
+
+ <tag><c>double_algs() =</c></tag>
+ <item><p><c>[{client2serverlist,simple_algs()},{server2client,simple_algs()}] | simple_algs()</c></p></item>
</taglist>
</section>
@@ -160,19 +174,58 @@
and <c>password</c>. However, those optins are not always desirable
to use from a security point of view.</p>
</item>
+
<tag><c><![CDATA[{public_key_alg, 'ssh-rsa' | 'ssh-dss'}]]></c></tag>
<item>
+ <note>
+ <p>This option is kept for compatibility. It is ignored if the <c>preferred_algorithms</c>
+ option is used. The equivalence of <c>{public_key_alg,'ssh-dss'}</c> is
+ <c>{preferred_algorithms, [{public_key,['ssh-dss','ssh-rsa']}]}</c>.</p>
+ </note>
<p>Sets the preferred public key algorithm to use for user
authentication. If the preferred algorithm fails,
the other algorithm is tried. The default is
to try <c><![CDATA['ssh-rsa']]></c> first.</p>
</item>
+
<tag><c><![CDATA[{pref_public_key_algs, list()}]]></c></tag>
<item>
+ <note>
+ <p>This option is kept for compatibility. It is ignored if the <c>preferred_algorithms</c>
+ option is used. The equivalence of <c>{pref_public_key_algs,['ssh-dss']}</c> is
+ <c>{preferred_algorithms, [{public_key,['ssh-dss']}]}</c>.</p>
+ </note>
<p>List of public key algorithms to try to use.
<c>'ssh-rsa'</c> and <c>'ssh-dss'</c> are available.
Overrides <c><![CDATA[{public_key_alg, 'ssh-rsa' | 'ssh-dss'}]]></c></p>
</item>
+
+ <tag><c><![CDATA[{preferred_algorithms, algs_list()}]]></c></tag>
+ <item>
+ <p>List of algorithms to use in the algorithm negotiation. The default <c>algs_list()</c> can
+ be obtained from <seealso marker="#default_algorithms/0">default_algorithms/0</seealso>.
+ </p>
+ <p>Here is an example of this option:</p>
+ <code>
+{preferred_algorithms,
+ [{public_key,['ssh-rsa','ssh-dss']},
+ {cipher,[{client2server,['aes128-ctr']},
+ {server2client,['aes128-cbc','3des-cbc']}]},
+ {mac,['hmac-sha2-256','hmac-sha1']},
+ {compression,[none,zlib]}
+}
+</code>
+ <p>The example specifies different algorithms in the two directions (client2server and server2client), for cipher but specifies the same
+algorithms for mac and compression in both directions. The kex (key exchange) and public key algorithms are set to their default values,
+kex is implicit but public_key is set explicitly.</p>
+
+ <warning>
+ <p>Changing the values can make a connection less secure. Do not change unless you
+ know exactly what you are doing. If you do not understand the values then you
+ are not supposed to change them.</p>
+ </warning>
+ </item>
+
<tag><c><![CDATA[{connect_timeout, timeout()}]]></c></tag>
<item>
<p>Sets a time-out on the transport layer
@@ -341,6 +394,33 @@
user. From a security perspective this option makes
the server very vulnerable.</p>
</item>
+
+ <tag><c><![CDATA[{preferred_algorithms, algs_list()}]]></c></tag>
+ <item>
+ <p>List of algorithms to use in the algorithm negotiation. The default <c>algs_list()</c> can
+ be obtained from <seealso marker="#default_algorithms/0">default_algorithms/0</seealso>.
+ </p>
+ <p>Here is an example of this option:</p>
+ <code>
+{preferred_algorithms,
+ [{public_key,['ssh-rsa','ssh-dss']},
+ {cipher,[{client2server,['aes128-ctr']},
+ {server2client,['aes128-cbc','3des-cbc']}]},
+ {mac,['hmac-sha2-256','hmac-sha1']},
+ {compression,[none,zlib]}
+}
+</code>
+ <p>The example specifies different algorithms in the two directions (client2server and server2client), for cipher but specifies the same
+algorithms for mac and compression in both directions. The kex (key exchange) and public key algorithms are set to their default values,
+kex is implicit but public_key is set explicitly.</p>
+
+ <warning>
+ <p>Changing the values can make a connection less secure. Do not change unless you
+ know exactly what you are doing. If you do not understand the values then you
+ are not supposed to change them.</p>
+ </warning>
+ </item>
+
<tag><c><![CDATA[{pwdfun, fun(User::string(), password::string()) -> boolean()}]]></c></tag>
<item>
<p>Provides a function for password validation. This function is called
@@ -445,6 +525,26 @@
</desc>
</func>
+ <func>
+ <name>default_algorithms() -> algs_list()</name>
+ <fsummary>Get a list declaring the supported algorithms</fsummary>
+ <desc>
+ <p>Returns a key-value list, where the keys are the different types of algorithms and the values are the
+ algorithms themselves. An example:</p>
+ <code>
+20> ssh:default_algorithms().
+[{kex,['diffie-hellman-group1-sha1']},
+ {public_key,['ssh-rsa','ssh-dss']},
+ {cipher,[{client2server,['aes128-ctr','aes128-cbc','3des-cbc']},
+ {server2client,['aes128-ctr','aes128-cbc','3des-cbc']}]},
+ {mac,[{client2server,['hmac-sha2-256','hmac-sha1']},
+ {server2client,['hmac-sha2-256','hmac-sha1']}]},
+ {compression,[{client2server,[none,zlib]},
+ {server2client,[none,zlib]}]}]
+21>
+</code>
+ </desc>
+ </func>
<func>
<name>shell(Host) -> </name>
diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl
index 71e7d77475..57f7ae8b5e 100644
--- a/lib/ssh/src/ssh.erl
+++ b/lib/ssh/src/ssh.erl
@@ -28,6 +28,7 @@
-export([start/0, start/1, stop/0, connect/3, connect/4, close/1, connection_info/2,
channel_info/3,
daemon/1, daemon/2, daemon/3,
+ default_algorithms/0,
stop_listener/1, stop_listener/2, stop_daemon/1, stop_daemon/2,
shell/1, shell/2, shell/3]).
@@ -208,6 +209,11 @@ shell(Host, Port, Options) ->
end.
%%--------------------------------------------------------------------
+%%--------------------------------------------------------------------
+default_algorithms() ->
+ ssh_transport:default_algorithms().
+
+%%--------------------------------------------------------------------
%%% Internal functions
%%--------------------------------------------------------------------
fix_idle_time(SshOptions) ->
@@ -259,7 +265,7 @@ do_start_daemon(Host, Port, Options, SocketOptions) ->
end.
handle_options(Opts) ->
- try handle_option(proplists:unfold(Opts), [], []) of
+ try handle_option(algs_compatibility(proplists:unfold(Opts)), [], []) of
{Inet, Ssh} ->
{handle_ip(Inet), Ssh}
catch
@@ -267,6 +273,35 @@ handle_options(Opts) ->
Error
end.
+
+algs_compatibility(Os) ->
+ %% Take care of old options 'public_key_alg' and 'pref_public_key_algs'
+ comp_pk(proplists:get_value(preferred_algorithms,Os),
+ proplists:get_value(pref_public_key_algs,Os),
+ proplists:get_value(public_key_alg, Os),
+ [{K,V} || {K,V} <- Os,
+ K =/= public_key_alg,
+ K =/= pref_public_key_algs]
+ ).
+
+comp_pk(undefined, undefined, undefined, Os) -> Os;
+comp_pk( PrefAlgs, _, _, Os) when PrefAlgs =/= undefined -> Os;
+
+comp_pk(undefined, undefined, ssh_dsa, Os) -> comp_pk(undefined, undefined, 'ssh-dss', Os);
+comp_pk(undefined, undefined, ssh_rsa, Os) -> comp_pk(undefined, undefined, 'ssh-rsa', Os);
+comp_pk(undefined, undefined, PK, Os) ->
+ PKs = [PK | ssh_transport:supported_algorithms(public_key)--[PK]],
+ [{preferred_algorithms, [{public_key,PKs}] } | Os];
+
+comp_pk(undefined, PrefPKs, _, Os) when PrefPKs =/= undefined ->
+ PKs = [case PK of
+ ssh_dsa -> 'ssh-dss';
+ ssh_rsa -> 'ssh-rsa';
+ _ -> PK
+ end || PK <- PrefPKs],
+ [{preferred_algorithms, [{public_key,PKs}]} | Os].
+
+
handle_option([], SocketOptions, SshOptions) ->
{SocketOptions, SshOptions};
handle_option([{system_dir, _} = Opt | Rest], SocketOptions, SshOptions) ->
@@ -279,8 +314,6 @@ handle_option([{silently_accept_hosts, _} = Opt | Rest], SocketOptions, SshOptio
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{user_interaction, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{public_key_alg, _} = Opt | Rest], SocketOptions, SshOptions) ->
- handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{connect_timeout, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{user, _} = Opt | Rest], SocketOptions, SshOptions) ->
@@ -297,10 +330,6 @@ handle_option([{pwdfun, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{key_cb, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{role, _} = Opt | Rest], SocketOptions, SshOptions) ->
- handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{compression, _} = Opt | Rest], SocketOptions, SshOptions) ->
- handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
%%Backwards compatibility
handle_option([{allow_user_interaction, Value} | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option({user_interaction, Value}) | SshOptions]);
@@ -331,7 +360,7 @@ handle_option([{exec, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{auth_methods, _} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
-handle_option([{pref_public_key_algs, _} = Opt | Rest], SocketOptions, SshOptions) ->
+handle_option([{preferred_algorithms,_} = Opt | Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
handle_option([{quiet_mode, _} = Opt|Rest], SocketOptions, SshOptions) ->
handle_option(Rest, SocketOptions, [handle_ssh_option(Opt) | SshOptions]);
@@ -367,19 +396,8 @@ handle_ssh_option({silently_accept_hosts, Value} = Opt) when is_boolean(Value) -
Opt;
handle_ssh_option({user_interaction, Value} = Opt) when is_boolean(Value) ->
Opt;
-handle_ssh_option({public_key_alg, ssh_dsa}) ->
- {public_key_alg, 'ssh-dss'};
-handle_ssh_option({public_key_alg, ssh_rsa}) ->
- {public_key_alg, 'ssh-rsa'};
-handle_ssh_option({public_key_alg, Value} = Opt) when Value == 'ssh-rsa'; Value == 'ssh-dss' ->
- Opt;
-handle_ssh_option({pref_public_key_algs, Value} = Opt) when is_list(Value), length(Value) >= 1 ->
- case handle_pref_algs(Value, []) of
- {true, NewOpts} ->
- NewOpts;
- _ ->
- throw({error, {eoptions, Opt}})
- end;
+handle_ssh_option({preferred_algorithms,[_|_]} = Opt) ->
+ handle_pref_algs(Opt);
handle_ssh_option({connect_timeout, Value} = Opt) when is_integer(Value); Value == infinity ->
Opt;
handle_ssh_option({max_sessions, Value} = Opt) when is_integer(Value), Value>0 ->
@@ -465,23 +483,83 @@ handle_inet_option({reuseaddr, _} = Opt) ->
%% Option verified by inet
handle_inet_option(Opt) ->
Opt.
+
+
%% Check preferred algs
-handle_pref_algs([], Acc) ->
- {true, lists:reverse(Acc)};
-handle_pref_algs([H|T], Acc) ->
- case H of
- ssh_dsa ->
- handle_pref_algs(T, ['ssh-dss'| Acc]);
- ssh_rsa ->
- handle_pref_algs(T, ['ssh-rsa'| Acc]);
- 'ssh-dss' ->
- handle_pref_algs(T, ['ssh-dss'| Acc]);
- 'ssh-rsa' ->
- handle_pref_algs(T, ['ssh-rsa'| Acc]);
- _ ->
- false
+
+handle_pref_algs({preferred_algorithms,Algs}) ->
+ try alg_duplicates(Algs, [], []) of
+ [] ->
+ {preferred_algorithms,
+ [try ssh_transport:supported_algorithms(Key)
+ of
+ DefAlgs -> handle_pref_alg(Key,Vals,DefAlgs)
+ catch
+ _:_ -> throw({error, {{eoptions, {preferred_algorithms,Key}},
+ "Bad preferred_algorithms key"}})
+ end || {Key,Vals} <- Algs]
+ };
+
+ Dups ->
+ throw({error, {{eoptions, {preferred_algorithms,Dups}}, "Duplicates found"}})
+ catch
+ _:_ ->
+ throw({error, {{eoptions, preferred_algorithms}, "Malformed"}})
end.
+alg_duplicates([{K,V}|KVs], Ks, Dups0) ->
+ Dups =
+ case lists:member(K,Ks) of
+ true ->
+ [K|Dups0];
+ false ->
+ Dups0
+ end,
+ case V--lists:usort(V) of
+ [] ->
+ alg_duplicates(KVs, [K|Ks], Dups);
+ Ds ->
+ alg_duplicates(KVs, [K|Ks], Dups++Ds)
+ end;
+alg_duplicates([], _Ks, Dups) ->
+ Dups.
+
+handle_pref_alg(Key,
+ Vs=[{client2server,C2Ss=[_|_]},{server2client,S2Cs=[_|_]}],
+ [{client2server,Sup_C2Ss},{server2client,Sup_S2Cs}]
+ ) ->
+ chk_alg_vs(Key, C2Ss, Sup_C2Ss),
+ chk_alg_vs(Key, S2Cs, Sup_S2Cs),
+ {Key, Vs};
+
+handle_pref_alg(Key,
+ Vs=[{server2client,[_|_]},{client2server,[_|_]}],
+ Sup=[{client2server,_},{server2client,_}]
+ ) ->
+ handle_pref_alg(Key, lists:reverse(Vs), Sup);
+
+handle_pref_alg(Key,
+ Vs=[V|_],
+ Sup=[{client2server,_},{server2client,_}]
+ ) when is_atom(V) ->
+ handle_pref_alg(Key, [{client2server,Vs},{server2client,Vs}], Sup);
+
+handle_pref_alg(Key,
+ Vs=[V|_],
+ Sup=[S|_]
+ ) when is_atom(V), is_atom(S) ->
+ chk_alg_vs(Key, Vs, Sup),
+ {Key, Vs};
+
+handle_pref_alg(Key, Vs, _) ->
+ throw({error, {{eoptions, {preferred_algorithms,[{Key,Vs}]}}, "Badly formed list"}}).
+
+chk_alg_vs(OptKey, Values, SupportedValues) ->
+ case (Values -- SupportedValues) of
+ [] -> Values;
+ Bad -> throw({error, {{eoptions, {OptKey,Bad}}, "Unsupported value(s) found"}})
+ end.
+
handle_ip(Inet) -> %% Default to ipv4
case lists:member(inet, Inet) of
true ->
diff --git a/lib/ssh/src/ssh_auth.erl b/lib/ssh/src/ssh_auth.erl
index 45c4d52d7e..197808754c 100644
--- a/lib/ssh/src/ssh_auth.erl
+++ b/lib/ssh/src/ssh_auth.erl
@@ -30,7 +30,8 @@
-export([publickey_msg/1, password_msg/1, keyboard_interactive_msg/1,
service_request_msg/1, init_userauth_request_msg/1,
userauth_request_msg/1, handle_userauth_request/3,
- handle_userauth_info_request/3, handle_userauth_info_response/2
+ handle_userauth_info_request/3, handle_userauth_info_response/2,
+ default_public_key_algorithms/0
]).
%%--------------------------------------------------------------------
@@ -115,33 +116,16 @@ init_userauth_request_msg(#ssh{opts = Opts} = Ssh) ->
service = "ssh-connection",
method = "none",
data = <<>>},
- case proplists:get_value(pref_public_key_algs, Opts, false) of
- false ->
- FirstAlg = proplists:get_value(public_key_alg, Opts, ?PREFERRED_PK_ALG),
- SecondAlg = other_alg(FirstAlg),
- Prefs = method_preference(FirstAlg, SecondAlg),
- ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
- userauth_preference = Prefs,
- userauth_methods = none,
- service = "ssh-connection"});
- Algs ->
- FirstAlg = lists:nth(1, Algs),
- case length(Algs) =:= 2 of
- true ->
- SecondAlg = other_alg(FirstAlg),
- Prefs = method_preference(FirstAlg, SecondAlg),
- ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
- userauth_preference = Prefs,
- userauth_methods = none,
- service = "ssh-connection"});
- _ ->
- Prefs = method_preference(FirstAlg),
- ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
- userauth_preference = Prefs,
- userauth_methods = none,
- service = "ssh-connection"})
- end
- end;
+
+
+ Algs = proplists:get_value(public_key,
+ proplists:get_value(preferred_algorithms, Opts, []),
+ default_public_key_algorithms()),
+ Prefs = method_preference(Algs),
+ ssh_transport:ssh_packet(Msg, Ssh#ssh{user = User,
+ userauth_preference = Prefs,
+ userauth_methods = none,
+ service = "ssh-connection"});
{error, no_user} ->
ErrStr = "Could not determine the users name",
throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_ILLEGAL_USER_NAME,
@@ -287,20 +271,20 @@ handle_userauth_info_response(#ssh_msg_userauth_info_response{},
"keyboard-interactive",
language = "en"}).
+
+default_public_key_algorithms() -> ?PREFERRED_PK_ALGS.
+
%%--------------------------------------------------------------------
%%% Internal functions
%%--------------------------------------------------------------------
-method_preference(Alg1, Alg2) ->
- [{"publickey", ?MODULE, publickey_msg, [Alg1]},
- {"publickey", ?MODULE, publickey_msg,[Alg2]},
- {"password", ?MODULE, password_msg, []},
- {"keyboard-interactive", ?MODULE, keyboard_interactive_msg, []}
- ].
-method_preference(Alg1) ->
- [{"publickey", ?MODULE, publickey_msg, [Alg1]},
- {"password", ?MODULE, password_msg, []},
- {"keyboard-interactive", ?MODULE, keyboard_interactive_msg, []}
- ].
+method_preference(Algs) ->
+ lists:foldr(fun(A, Acc) ->
+ [{"publickey", ?MODULE, publickey_msg, [A]} | Acc]
+ end,
+ [{"password", ?MODULE, password_msg, []},
+ {"keyboard-interactive", ?MODULE, keyboard_interactive_msg, []}
+ ],
+ Algs).
user_name(Opts) ->
Env = case os:type() of
@@ -418,10 +402,6 @@ keyboard_interact_fun(KbdInteractFun, Name, Instr, PromptInfos, NumPrompts) ->
language = "en"}})
end.
-other_alg('ssh-rsa') ->
- 'ssh-dss';
-other_alg('ssh-dss') ->
- 'ssh-rsa'.
decode_public_key_v2(<<?UINT32(Len0), _:Len0/binary,
?UINT32(Len1), BinE:Len1/binary,
?UINT32(Len2), BinN:Len2/binary>>
diff --git a/lib/ssh/src/ssh_auth.hrl b/lib/ssh/src/ssh_auth.hrl
index 6cd8e6bf14..764c9f4246 100644
--- a/lib/ssh/src/ssh_auth.hrl
+++ b/lib/ssh/src/ssh_auth.hrl
@@ -23,7 +23,7 @@
-define(SUPPORTED_AUTH_METHODS, "publickey,keyboard-interactive,password").
--define(PREFERRED_PK_ALG, 'ssh-rsa').
+-define(PREFERRED_PK_ALGS, ['ssh-rsa','ssh-dss']).
-define(SSH_MSG_USERAUTH_REQUEST, 50).
-define(SSH_MSG_USERAUTH_FAILURE, 51).
diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl
index 65208ae158..ca63d2194f 100644
--- a/lib/ssh/src/ssh_connection_handler.erl
+++ b/lib/ssh/src/ssh_connection_handler.erl
@@ -33,7 +33,7 @@
-include("ssh_transport.hrl").
-include("ssh_auth.hrl").
-include("ssh_connect.hrl").
-
+-compile(export_all).
-export([start_link/3]).
%% Internal application API
@@ -1156,54 +1156,38 @@ init_ssh(server = Role, Vsn, Version, Options, Socket) ->
supported_host_keys(client, _, Options) ->
try
- case extract_algs(proplists:get_value(pref_public_key_algs, Options, false), []) of
- false ->
- ["ssh-rsa", "ssh-dss"];
- Algs ->
- Algs
+ case proplists:get_value(public_key,
+ proplists:get_value(preferred_algorithms,Options,[])
+ ) of
+ undefined ->
+ ssh_auth:default_public_key_algorithms();
+ L ->
+ L -- (L--ssh_auth:default_public_key_algorithms())
end
+ of
+ [] ->
+ {stop, {shutdown, "No public key algs"}};
+ Algs ->
+ [atom_to_list(A) || A<-Algs]
catch
exit:Reason ->
{stop, {shutdown, Reason}}
end;
supported_host_keys(server, KeyCb, Options) ->
- lists:foldl(fun(Type, Acc) ->
- case available_host_key(KeyCb, Type, Options) of
- {error, _} ->
- Acc;
- Alg ->
- [Alg | Acc]
- end
- end, [],
- %% Prefered alg last so no need to reverse
- ["ssh-dss", "ssh-rsa"]).
-extract_algs(false, _) ->
- false;
-extract_algs([],[]) ->
- false;
-extract_algs([], NewList) ->
- lists:reverse(NewList);
-extract_algs([H|T], NewList) ->
- case H of
- 'ssh-dss' ->
- extract_algs(T, ["ssh-dss"|NewList]);
- 'ssh-rsa' ->
- extract_algs(T, ["ssh-rsa"|NewList])
- end.
-available_host_key(KeyCb, "ssh-dss"= Alg, Opts) ->
- case KeyCb:host_key('ssh-dss', Opts) of
- {ok, _} ->
- Alg;
- Other ->
- Other
- end;
-available_host_key(KeyCb, "ssh-rsa" = Alg, Opts) ->
- case KeyCb:host_key('ssh-rsa', Opts) of
- {ok, _} ->
- Alg;
- Other ->
- Other
- end.
+ Algs=
+ [atom_to_list(A) || A <- proplists:get_value(public_key,
+ proplists:get_value(preferred_algorithms,Options,[]),
+ ssh_auth:default_public_key_algorithms()
+ ),
+ available_host_key(KeyCb, A, Options)
+ ],
+ Algs.
+
+
+%% Alg :: atom()
+available_host_key(KeyCb, Alg, Opts) ->
+ element(1, catch KeyCb:host_key(Alg, Opts)) == ok.
+
send_msg(Msg, #state{socket = Socket, transport_cb = Transport}) ->
Transport:send(Socket, Msg).
diff --git a/lib/ssh/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl
index d6414bab6c..7162d18b19 100644
--- a/lib/ssh/src/ssh_transport.erl
+++ b/lib/ssh/src/ssh_transport.erl
@@ -31,6 +31,8 @@
-export([versions/2, hello_version_msg/1]).
-export([next_seqnum/1, decrypt_first_block/2, decrypt_blocks/3,
+ supported_algorithms/0, supported_algorithms/1,
+ default_algorithms/0, default_algorithms/1,
is_valid_mac/3,
handle_hello_version/1,
key_exchange_init_msg/1,
@@ -42,6 +44,68 @@
unpack/3, decompress/2, ssh_packet/2, pack/2, msg_data/1,
sign/3, verify/4]).
+%%%----------------------------------------------------------------------------
+%%%
+%%% There is a difference between supported and default algorithms. The
+%%% SUPPORTED algorithms can be handled (maybe untested...). The DEFAULT ones
+%%% are announced in ssh_msg_kexinit and in ssh:default_algorithms/0 to the
+%%% user.
+%%%
+%%% A supported algorithm can be requested in the option 'preferred_algorithms',
+%%% but may give unexpected results because of being promoted to default.
+%%%
+%%% This makes it possible to add experimental algorithms (in supported_algorithms)
+%%% and test them without letting the default users know about them.
+%%%
+
+default_algorithms() -> [{K,default_algorithms(K)} || K <- algo_classes()].
+
+algo_classes() -> [kex, public_key, cipher, mac, compression].
+
+default_algorithms(compression) ->
+ %% Do not announce '[email protected]' because there seem to be problems
+ supported_algorithms(compression, same(['[email protected]']));
+default_algorithms(Alg) ->
+ supported_algorithms(Alg).
+
+
+supported_algorithms() -> [{K,supported_algorithms(K)} || K <- algo_classes()].
+
+supported_algorithms(kex) ->
+ ['diffie-hellman-group1-sha1'];
+supported_algorithms(public_key) ->
+ ssh_auth:default_public_key_algorithms();
+supported_algorithms(cipher) ->
+ Supports = crypto:supports(),
+ CipherAlgos = [{aes_ctr, 'aes128-ctr'}, {aes_cbc128, 'aes128-cbc'}, {des3_cbc, '3des-cbc'}],
+ Algs = [SshAlgo ||
+ {CryptoAlgo, SshAlgo} <- CipherAlgos,
+ lists:member(CryptoAlgo, proplists:get_value(ciphers, Supports, []))],
+ same(Algs);
+supported_algorithms(mac) ->
+ Supports = crypto:supports(),
+ HashAlgos = [{sha256, 'hmac-sha2-256'}, {sha, 'hmac-sha1'}],
+ Algs = [SshAlgo ||
+ {CryptoAlgo, SshAlgo} <- HashAlgos,
+ lists:member(CryptoAlgo, proplists:get_value(hashs, Supports, []))],
+ same(Algs);
+supported_algorithms(compression) ->
+ same(['none','zlib','[email protected]']).
+
+
+supported_algorithms(Key, [{client2server,BL1},{server2client,BL2}]) ->
+ [{client2server,As1},{server2client,As2}] = supported_algorithms(Key),
+ [{client2server,As1--BL1},{server2client,As2--BL2}];
+supported_algorithms(Key, BlackList) ->
+ supported_algorithms(Key) -- BlackList.
+
+
+
+
+same(Algs) -> [{client2server,Algs}, {server2client,Algs}].
+
+
+%%%----------------------------------------------------------------------------
versions(client, Options)->
Vsn = proplists:get_value(vsn, Options, ?DEFAULT_CLIENT_VERSION),
{Vsn, format_version(Vsn, software_version(Options))};
@@ -128,62 +192,45 @@ key_exchange_init_msg(Ssh0) ->
kex_init(#ssh{role = Role, opts = Opts, available_host_keys = HostKeyAlgs}) ->
Random = ssh_bits:random(16),
- Compression = case proplists:get_value(compression, Opts, none) of
- openssh_zlib -> ["[email protected]", "none"];
- zlib -> ["zlib", "none"];
- none -> ["none", "zlib"]
- end,
- kexinit_messsage(Role, Random, Compression, HostKeyAlgs).
+ PrefAlgs =
+ case proplists:get_value(preferred_algorithms,Opts) of
+ undefined ->
+ default_algorithms();
+ Algs0 ->
+ Algs0
+ end,
+ kexinit_message(Role, Random, PrefAlgs, HostKeyAlgs).
key_init(client, Ssh, Value) ->
Ssh#ssh{c_keyinit = Value};
key_init(server, Ssh, Value) ->
Ssh#ssh{s_keyinit = Value}.
-available_ssh_algos() ->
- Supports = crypto:supports(),
- CipherAlgos = [{aes_ctr, "aes128-ctr"}, {aes_cbc128, "aes128-cbc"}, {des3_cbc, "3des-cbc"}],
- Ciphers = [SshAlgo ||
- {CryptoAlgo, SshAlgo} <- CipherAlgos,
- lists:member(CryptoAlgo, proplists:get_value(ciphers, Supports, []))],
- HashAlgos = [{sha256, "hmac-sha2-256"}, {sha, "hmac-sha1"}],
- Hashs = [SshAlgo ||
- {CryptoAlgo, SshAlgo} <- HashAlgos,
- lists:member(CryptoAlgo, proplists:get_value(hashs, Supports, []))],
- {Ciphers, Hashs}.
-
-kexinit_messsage(client, Random, Compression, HostKeyAlgs) ->
- {CipherAlgs, HashAlgs} = available_ssh_algos(),
- #ssh_msg_kexinit{
- cookie = Random,
- kex_algorithms = ["diffie-hellman-group1-sha1"],
- server_host_key_algorithms = HostKeyAlgs,
- encryption_algorithms_client_to_server = CipherAlgs,
- encryption_algorithms_server_to_client = CipherAlgs,
- mac_algorithms_client_to_server = HashAlgs,
- mac_algorithms_server_to_client = HashAlgs,
- compression_algorithms_client_to_server = Compression,
- compression_algorithms_server_to_client = Compression,
- languages_client_to_server = [],
- languages_server_to_client = []
- };
-kexinit_messsage(server, Random, Compression, HostKeyAlgs) ->
- {CipherAlgs, HashAlgs} = available_ssh_algos(),
+kexinit_message(_Role, Random, Algs, HostKeyAlgs) ->
#ssh_msg_kexinit{
cookie = Random,
- kex_algorithms = ["diffie-hellman-group1-sha1"],
+ kex_algorithms = to_strings( get_algs(kex,Algs) ),
server_host_key_algorithms = HostKeyAlgs,
- encryption_algorithms_client_to_server = CipherAlgs,
- encryption_algorithms_server_to_client = CipherAlgs,
- mac_algorithms_client_to_server = HashAlgs,
- mac_algorithms_server_to_client = HashAlgs,
- compression_algorithms_client_to_server = Compression,
- compression_algorithms_server_to_client = Compression,
+ encryption_algorithms_client_to_server = c2s(cipher,Algs),
+ encryption_algorithms_server_to_client = s2c(cipher,Algs),
+ mac_algorithms_client_to_server = c2s(mac,Algs),
+ mac_algorithms_server_to_client = s2c(mac,Algs),
+ compression_algorithms_client_to_server = c2s(compression,Algs),
+ compression_algorithms_server_to_client = s2c(compression,Algs),
languages_client_to_server = [],
languages_server_to_client = []
}.
+c2s(Key, Algs) -> x2y(client2server, Key, Algs).
+s2c(Key, Algs) -> x2y(server2client, Key, Algs).
+
+x2y(DirectionKey, Key, Algs) -> to_strings(proplists:get_value(DirectionKey, get_algs(Key,Algs))).
+
+get_algs(Key, Algs) -> proplists:get_value(Key, Algs, default_algorithms(Key)).
+
+to_strings(L) -> lists:map(fun erlang:atom_to_list/1, L).
+
new_keys_message(Ssh0) ->
{SshPacket, Ssh} =
ssh_packet(#ssh_msg_newkeys{}, Ssh0),
@@ -448,6 +495,7 @@ select_algorithm(Role, Client, Server) ->
decompress = Decompression,
c_lng = C_Lng,
s_lng = S_Lng},
+%%ct:pal("~p~n Client=~p~n Server=~p~n Alg=~p~n",[Role,Client,Server,Alg]),
{ok, Alg}.
select_encrypt_decrypt(client, Client, Server) ->
diff --git a/lib/ssh/test/ssh_basic_SUITE.erl b/lib/ssh/test/ssh_basic_SUITE.erl
index aaf0fa9905..cff695681e 100644
--- a/lib/ssh/test/ssh_basic_SUITE.erl
+++ b/lib/ssh/test/ssh_basic_SUITE.erl
@@ -56,6 +56,7 @@ all() ->
ssh_daemon_minimal_remote_max_packet_size_option,
ssh_msg_debug_fun_option_client,
ssh_msg_debug_fun_option_server,
+ preferred_algorithms,
id_string_no_opt_client,
id_string_own_string_client,
id_string_random_client,
@@ -92,6 +93,7 @@ basic_tests() ->
%%--------------------------------------------------------------------
init_per_suite(Config) ->
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
Config;
@@ -289,7 +291,7 @@ exec_compressed(Config) when is_list(Config) ->
UserDir = ?config(priv_dir, Config),
{Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},{user_dir, UserDir},
- {compression, zlib},
+ {preferred_algorithms,[{compression, [zlib]}]},
{failfun, fun ssh_test_lib:failfun/2}]),
ConnectionRef =
@@ -1064,6 +1066,57 @@ ssh_daemon_minimal_remote_max_packet_size_option(Config) ->
ssh:stop_daemon(Server).
%%--------------------------------------------------------------------
+%% This test try every algorithm by connecting to an Erlang server
+preferred_algorithms(Config) ->
+ SystemDir = ?config(data_dir, Config),
+ PrivDir = ?config(priv_dir, Config),
+ UserDir = filename:join(PrivDir, nopubkey), % to make sure we don't use public-key-auth
+ file:make_dir(UserDir),
+
+ {Server, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user_passwords, [{"vego", "morot"}]},
+ {failfun, fun ssh_test_lib:failfun/2}]),
+ Available = ssh:default_algorithms(),
+ Tests = [[{Tag,[Alg]}] || {Tag, SubAlgs} <- Available,
+ is_atom(hd(SubAlgs)),
+ Alg <- SubAlgs]
+ ++ [[{Tag,[{T1,[A1]},{T2,[A2]}]}] || {Tag, [{T1,As1},{T2,As2}]} <- Available,
+ A1 <- As1,
+ A2 <- As2],
+ ct:log("TESTS: ~p",[Tests]),
+ [connect_exec_channel(Host,Port,PrefAlgs) || PrefAlgs <- Tests],
+ ssh:stop_daemon(Server).
+
+
+connect_exec_channel(_Host, Port, Algs) ->
+ ct:log("Try ~p",[Algs]),
+ ConnectionRef = ssh_test_lib:connect(Port, [{silently_accept_hosts, true},
+ {user_interaction, false},
+ {user, "vego"},
+ {password, "morot"},
+ {preferred_algorithms,Algs}
+ ]),
+ chan_exec(ConnectionRef, "2*21.", <<"42\n">>),
+ ssh:close(ConnectionRef).
+
+chan_exec(ConnectionRef, Cmnd, Expected) ->
+ {ok, ChannelId0} = ssh_connection:session_channel(ConnectionRef, infinity),
+ success = ssh_connection:exec(ConnectionRef, ChannelId0,Cmnd, infinity),
+ Data0 = {ssh_cm, ConnectionRef, {data, ChannelId0, 0, Expected}},
+ case ssh_test_lib:receive_exec_result(Data0) of
+ expected ->
+ ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId0);
+ {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId0, 0}}
+ = ExitStatus0} ->
+ ct:pal("0: Collected data ~p", [ExitStatus0]),
+ ssh_test_lib:receive_exec_result(Data0,
+ ConnectionRef, ChannelId0);
+ Other0 ->
+ ct:fail(Other0)
+ end.
+
+%%--------------------------------------------------------------------
id_string_no_opt_client(Config) ->
{Server, _Host, Port} = fake_daemon(Config),
{error,_} = ssh:connect("localhost", Port, [], 1000),
@@ -1233,12 +1286,15 @@ openssh_zlib_basic_test(Config) ->
{Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
{user_dir, UserDir},
+ {preferred_algorithms,[{compression, ['[email protected]']}]},
{failfun, fun ssh_test_lib:failfun/2}]),
ConnectionRef =
ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true},
{user_dir, UserDir},
{user_interaction, false},
- {compression, openssh_zlib}]),
+ {preferred_algorithms,[{compression, ['[email protected]',
+ none]}]}
+ ]),
ok = ssh:close(ConnectionRef),
ssh:stop_daemon(Pid).
diff --git a/lib/ssh/test/ssh_connection_SUITE.erl b/lib/ssh/test/ssh_connection_SUITE.erl
index db51f65509..f0c337cf2f 100644
--- a/lib/ssh/test/ssh_connection_SUITE.erl
+++ b/lib/ssh/test/ssh_connection_SUITE.erl
@@ -65,6 +65,7 @@ ptty() ->
%%--------------------------------------------------------------------
init_per_suite(Config) ->
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
Config;
diff --git a/lib/ssh/test/ssh_sftp_SUITE.erl b/lib/ssh/test/ssh_sftp_SUITE.erl
index cb74a27638..850b1cbf6b 100644
--- a/lib/ssh/test/ssh_sftp_SUITE.erl
+++ b/lib/ssh/test/ssh_sftp_SUITE.erl
@@ -49,6 +49,7 @@ all() ->
init_per_suite(Config) ->
+ catch crypto:stop(),
case (catch crypto:start()) of
ok ->
ssh:start(),
diff --git a/lib/ssh/test/ssh_sftpd_SUITE.erl b/lib/ssh/test/ssh_sftpd_SUITE.erl
index 0ce8eec906..925b02a437 100644
--- a/lib/ssh/test/ssh_sftpd_SUITE.erl
+++ b/lib/ssh/test/ssh_sftpd_SUITE.erl
@@ -68,6 +68,7 @@ groups() ->
%%--------------------------------------------------------------------
init_per_suite(Config) ->
+ catch crypto:stop(),
case (catch crypto:start()) of
ok ->
DataDir = ?config(data_dir, Config),
diff --git a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl
index cc34cc0793..eac7575486 100644
--- a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl
+++ b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl
@@ -52,6 +52,7 @@ groups() ->
init_per_suite(Config) ->
catch ssh:stop(),
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
DataDir = ?config(data_dir, Config),
diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl
index a61fd2dd41..277e3a1b08 100644
--- a/lib/ssh/test/ssh_to_openssh_SUITE.erl
+++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl
@@ -60,6 +60,7 @@ groups() ->
].
init_per_suite(Config) ->
+ catch crypto:stop(),
case catch crypto:start() of
ok ->
case gen_tcp:connect("localhost", 22, []) of
@@ -166,9 +167,11 @@ erlang_client_openssh_server_exec_compressed() ->
[{doc, "Test that compression option works"}].
erlang_client_openssh_server_exec_compressed(Config) when is_list(Config) ->
+ CompressAlgs = [zlib, '[email protected]',none],
ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true},
{user_interaction, false},
- {compression, zlib}]),
+ {preferred_algorithms,
+ [{compression,CompressAlgs}]}]),
{ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity),
success = ssh_connection:exec(ConnectionRef, ChannelId,
"echo testing", infinity),
@@ -326,8 +329,11 @@ erlang_server_openssh_client_exec_compressed(Config) when is_list(Config) ->
PrivDir = ?config(priv_dir, Config),
KnownHosts = filename:join(PrivDir, "known_hosts"),
+%% CompressAlgs = [zlib, '[email protected]'], % Does not work
+ CompressAlgs = [zlib],
{Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
- {compression, zlib},
+ {preferred_algorithms,
+ [{compression, CompressAlgs}]},
{failfun, fun ssh_test_lib:failfun/2}]),
ct:sleep(500),
diff --git a/lib/ssh/test/ssh_unicode_SUITE.erl b/lib/ssh/test/ssh_unicode_SUITE.erl
index cc916673b3..07d51335c6 100644
--- a/lib/ssh/test/ssh_unicode_SUITE.erl
+++ b/lib/ssh/test/ssh_unicode_SUITE.erl
@@ -55,6 +55,7 @@ all() ->
init_per_suite(Config) ->
+ catch crypto:stop(),
case {file:native_name_encoding(), (catch crypto:start())} of
{utf8, ok} ->
ssh:start(),
diff --git a/lib/stdlib/src/erl_anno.erl b/lib/stdlib/src/erl_anno.erl
index 9fb767fc93..fa83375c34 100644
--- a/lib/stdlib/src/erl_anno.erl
+++ b/lib/stdlib/src/erl_anno.erl
@@ -150,9 +150,7 @@ is_filename(T) ->
is_list(T) orelse is_binary(T).
is_string(T) ->
- try lists:all(fun(C) when is_integer(C), C >= 0 -> true end, T)
- catch _:_ -> false
- end.
+ is_list(T).
-spec column(Anno) -> column() | 'undefined' when
Anno :: anno().
diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl
index 714c260bda..ac92004061 100644
--- a/lib/stdlib/src/erl_lint.erl
+++ b/lib/stdlib/src/erl_lint.erl
@@ -609,22 +609,30 @@ pack_warnings(Ws) ->
%% add_warning(ErrorDescriptor, State) -> State'
%% add_warning(Line, Error, State) -> State'
-add_error(E, St) -> St#lint{errors=[{St#lint.file,E}|St#lint.errors]}.
+add_error(E, St) -> add_lint_error(E, St#lint.file, St).
add_error(Anno, E, St) ->
- {File,Location} = loc(Anno),
- add_error({Location,erl_lint,E}, St#lint{file = File}).
+ {File,Location} = loc(Anno, St),
+ add_lint_error({Location,erl_lint,E}, File, St).
-add_warning(W, St) -> St#lint{warnings=[{St#lint.file,W}|St#lint.warnings]}.
+add_lint_error(E, File, St) ->
+ St#lint{errors=[{File,E}|St#lint.errors]}.
+
+add_warning(W, St) -> add_lint_warning(W, St#lint.file, St).
add_warning(FileLine, W, St) ->
- {File,Location} = loc(FileLine),
- add_warning({Location,erl_lint,W}, St#lint{file = File}).
+ {File,Location} = loc(FileLine, St),
+ add_lint_warning({Location,erl_lint,W}, File, St).
+
+add_lint_warning(W, File, St) ->
+ St#lint{warnings=[{File,W}|St#lint.warnings]}.
-loc(Anno) ->
- File = erl_anno:file(Anno),
+loc(Anno, St) ->
Location = erl_anno:location(Anno),
- {File,Location}.
+ case erl_anno:file(Anno) of
+ undefined -> {St#lint.file,Location};
+ File -> {File,Location}
+ end.
%% forms([Form], State) -> State'
@@ -667,11 +675,21 @@ eval_file_attribute(Forms, St) ->
eval_file_attr([{attribute,_L,file,{File,_Line}}=Form | Forms], _File) ->
[Form | eval_file_attr(Forms, File)];
eval_file_attr([Form0 | Forms], File) ->
- Form = set_file(Form0, File),
+ Form = set_form_file(Form0, File),
[Form | eval_file_attr(Forms, File)];
eval_file_attr([], _File) ->
[].
+%% Sets the file only on the form. This is used on post-traversal.
+%% For the remaining of the AST we rely on #lint.file.
+
+set_form_file({attribute,L,K,V}, File) ->
+ {attribute,erl_anno:set_file(File, L),K,V};
+set_form_file({function,L,N,A,C}, File) ->
+ {function,erl_anno:set_file(File, L),N,A,C};
+set_form_file(Form, _File) ->
+ Form.
+
set_file(T, File) ->
F = fun(Anno) -> erl_anno:set_file(File, Anno) end,
erl_parse:map_anno(F, T).
@@ -796,10 +814,10 @@ disallowed_compile_flags(Forms, St0) ->
%% There are (still) no line numbers in St0#lint.compile.
Errors0 = [ {St0#lint.file,{L,erl_lint,disallowed_nowarn_bif_clash}} ||
{attribute,A,compile,nowarn_bif_clash} <- Forms,
- {_,L} <- [loc(A)] ],
+ {_,L} <- [loc(A, St0)] ],
Errors1 = [ {St0#lint.file,{L,erl_lint,disallowed_nowarn_bif_clash}} ||
{attribute,A,compile,{nowarn_bif_clash, {_,_}}} <- Forms,
- {_,L} <- [loc(A)] ],
+ {_,L} <- [loc(A, St0)] ],
Disabled = (not is_warn_enabled(bif_clash, St0)),
Errors = if
Disabled andalso Errors0 =:= [] ->
@@ -924,7 +942,7 @@ behaviour_conflicting(AllBfs, St) ->
behaviour_add_conflicts(R, St).
behaviour_add_conflicts([{Cb,[{FirstLoc,FirstB}|Cs]}|T], St0) ->
- FirstL = element(2, loc(FirstLoc)),
+ FirstL = element(2, loc(FirstLoc, St0)),
St = behaviour_add_conflict(Cs, Cb, FirstL, FirstB, St0),
behaviour_add_conflicts(T, St);
behaviour_add_conflicts([], St) -> St.
@@ -1142,7 +1160,7 @@ check_unused_records(Forms, St0) ->
end, St0#lint.records, UsedRecords),
Unused = [{Name,FileLine} ||
{Name,{FileLine,_Fields}} <- dict:to_list(URecs),
- element(1, loc(FileLine)) =:= FirstFile],
+ element(1, loc(FileLine, St0)) =:= FirstFile],
foldl(fun ({N,L}, St) ->
add_warning(L, {unused_record, N}, St)
end, St0, Unused);
@@ -1335,14 +1353,15 @@ check_on_load(St) -> St.
-spec call_function(line(), atom(), arity(), lint_state()) -> lint_state().
%% Add to both called and calls.
-call_function(Line, F, A, #lint{usage=Usage0,called=Cd,func=Func}=St) ->
+call_function(Line, F, A, #lint{usage=Usage0,called=Cd,func=Func,file=File}=St) ->
#usage{calls = Cs} = Usage0,
NA = {F,A},
Usage = case Cs of
undefined -> Usage0;
_ -> Usage0#usage{calls=dict:append(Func, NA, Cs)}
end,
- St#lint{called=[{NA,Line}|Cd], usage=Usage}.
+ Anno = erl_anno:set_file(File, Line),
+ St#lint{called=[{NA,Anno}|Cd], usage=Usage}.
%% function(Line, Name, Arity, Clauses, State) -> State.
@@ -2121,7 +2140,7 @@ expr({'receive',Line,Cs,To,ToEs}, Vt, St0) ->
{Cvt,St3} = icrt_clauses(Cs, Vt, St2),
%% Csvts = [vtnew(Tevt, Vt)|Cvt], %This is just NEW variables!
Csvts = [Tevt|Cvt],
- Rvt = icrt_export(Csvts, Vt, {'receive',Line}),
+ Rvt = icrt_export(Csvts, Vt, {'receive',Line}, St3),
{vtmerge([Tvt,Tevt,Rvt]),St3};
expr({'fun',Line,Body}, Vt, St) ->
%%No one can think funs export!
@@ -2982,7 +3001,7 @@ check_unused_types(Forms, #lint{usage=Usage, types=Ts, exp_types=ExpTs}=St) ->
UsedTypes = gb_sets:from_list(L),
FoldFun =
fun(Type, #typeinfo{line = FileLine}, AccSt) ->
- case loc(FileLine) of
+ case loc(FileLine, AccSt) of
{FirstFile, _} ->
case gb_sets:is_member(Type, UsedTypes) of
true -> AccSt;
@@ -3020,7 +3039,7 @@ check_local_opaque_types(St) ->
icrt_clauses(Cs, In, Vt, St0) ->
{Csvt,St1} = icrt_clauses(Cs, Vt, St0),
- UpdVt = icrt_export(Csvt, Vt, In),
+ UpdVt = icrt_export(Csvt, Vt, In, St1),
{UpdVt,St1}.
%% icrt_clauses(Clauses, ImportVarTable, State) ->
@@ -3037,8 +3056,8 @@ icrt_clause({clause,_Line,H,G,B}, Vt0, St0) ->
{Bvt,St3} = exprs(B, vtupdate(Vt2, Vt0), St2),
{vtupdate(Bvt, Vt2),St3}.
-icrt_export(Vts, Vt, {Tag,Attrs}) ->
- {_File,Loc} = loc(Attrs),
+icrt_export(Vts, Vt, {Tag,Attrs}, St) ->
+ {_File,Loc} = loc(Attrs, St),
icrt_export(lists:merge(Vts), Vt, {Tag,Loc}, length(Vts), []).
icrt_export([{V,{{export,_},_,_}}|Vs0], [{V,{{export,_}=S0,_,Ls}}|Vt],
@@ -3395,7 +3414,7 @@ vtupdate(Uvt, Vt0) ->
%% Return all new variables in UpdVarTable as unsafe.
vtunsafe({Tag,FileLine}, Uvt, Vt) ->
- {_File,Line} = loc(FileLine),
+ Line = erl_anno:location(FileLine),
[{V,{{unsafe,{Tag,Line}},U,Ls}} || {V,{_,U,Ls}} <- vtnew(Uvt, Vt)].
%% vtmerge(VarTable, VarTable) -> VarTable.
diff --git a/lib/stdlib/src/stdlib.appup.src b/lib/stdlib/src/stdlib.appup.src
index ee87a8ddb2..b3569c2848 100644
--- a/lib/stdlib/src/stdlib.appup.src
+++ b/lib/stdlib/src/stdlib.appup.src
@@ -1,7 +1,7 @@
%% -*- erlang -*-
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1999-2014. All Rights Reserved.
+%% Copyright Ericsson AB 1999-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -17,9 +17,7 @@
%% %CopyrightEnd%
{"%VSN%",
%% Up from - max one major revision back
- [{<<"2\\.[1-3](\\.[0-9]+)*">>,[restart_new_emulator]}, %% 17.1-17.3
- {<<"2\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}], %% 17.0
+ [{<<"2\\.[0-4](\\.[0-9]+)*">>,[restart_new_emulator]}], %% 17.0-17.5
%% Down to - max one major revision back
- [{<<"2\\.[1-3](\\.[0-9]+)*">>,[restart_new_emulator]}, %% 17.1-17.3
- {<<"2\\.0(\\.[0-9]+)*">>,[restart_new_emulator]}] %% 17.0
+ [{<<"2\\.[0-4](\\.[0-9]+)*">>,[restart_new_emulator]}] %% 17.0-17.5
}.
diff --git a/lib/stdlib/src/zip.erl b/lib/stdlib/src/zip.erl
index 3c67bd67c6..f986c0081d 100644
--- a/lib/stdlib/src/zip.erl
+++ b/lib/stdlib/src/zip.erl
@@ -24,7 +24,7 @@
list_dir/1, list_dir/2, table/1, table/2,
t/1, tt/1]).
-%% unzipping peicemeal
+%% unzipping piecemeal
-export([openzip_open/1, openzip_open/2,
openzip_get/1, openzip_get/2,
openzip_t/1, openzip_tt/1,
diff --git a/lib/stdlib/test/binary_module_SUITE.erl b/lib/stdlib/test/binary_module_SUITE.erl
index 5248870744..8d26c77c9b 100644
--- a/lib/stdlib/test/binary_module_SUITE.erl
+++ b/lib/stdlib/test/binary_module_SUITE.erl
@@ -993,43 +993,51 @@ random_parts(X,N) ->
random_ref_comp(doc) ->
["Test pseudorandomly generated cases against reference imlementation"];
random_ref_comp(Config) when is_list(Config) ->
- ?line put(success_counter,0),
- ?line random:seed({1271,769940,559934}),
- ?line do_random_match_comp(5000,{1,40},{30,1000}),
+ put(success_counter,0),
+ random:seed({1271,769940,559934}),
+ Nr = {1,40},
+ Hr = {30,1000},
+ I1 = 1500,
+ I2 = 5,
+ do_random_match_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_match_comp2(5000,{1,40},{30,1000}),
+ do_random_match_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_match_comp3(5000,{1,40},{30,1000}),
+ do_random_match_comp3(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_match_comp4(5000,{1,40},{30,1000}),
+ do_random_match_comp4(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_matches_comp(5000,{1,40},{30,1000}),
+ do_random_matches_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_matches_comp2(5000,{1,40},{30,1000}),
+ do_random_matches_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_matches_comp3(5,{1,40},{30,1000}),
- ?line erts_debug:set_internal_state(available_internal_state,true),
- ?line io:format("oldlimit: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,100)]),
- ?line do_random_match_comp(5000,{1,40},{30,1000}),
- ?line do_random_matches_comp3(5,{1,40},{30,1000}),
- ?line io:format("limit was: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,default)]),
- ?line erts_debug:set_internal_state(available_internal_state,false),
+ do_random_matches_comp3(I2,Nr,Hr),
+ erts_debug:set_internal_state(available_internal_state,true),
+ io:format("oldlimit: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,100)]),
+ do_random_match_comp(I1,Nr,Hr),
+ do_random_matches_comp3(I2,Nr,Hr),
+ io:format("limit was: ~p~n",[ erts_debug:set_internal_state(binary_loop_limit,default)]),
+ erts_debug:set_internal_state(available_internal_state,false),
ok.
random_ref_sr_comp(doc) ->
["Test pseudorandomly generated cases against reference imlementation of split and replace"];
random_ref_sr_comp(Config) when is_list(Config) ->
- ?line put(success_counter,0),
- ?line random:seed({1271,769940,559934}),
- ?line do_random_split_comp(5000,{1,40},{30,1000}),
+ put(success_counter,0),
+ random:seed({1271,769940,559934}),
+ Nr = {1,40},
+ Hr = {30,1000},
+ I1 = 1500,
+ do_random_split_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_replace_comp(5000,{1,40},{30,1000}),
+ do_random_replace_comp(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_split_comp2(5000,{1,40},{30,1000}),
+ do_random_split_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
- ?line do_random_replace_comp2(5000,{1,40},{30,1000}),
+ do_random_replace_comp2(I1,Nr,Hr),
io:format("Number of successes: ~p~n",[get(success_counter)]),
ok.
+
random_ref_fla_comp(doc) ->
["Test pseudorandomly generated cases against reference imlementation of split and replace"];
random_ref_fla_comp(Config) when is_list(Config) ->
diff --git a/lib/stdlib/test/erl_anno_SUITE.erl b/lib/stdlib/test/erl_anno_SUITE.erl
index 7632fbd324..d024f6907d 100644
--- a/lib/stdlib/test/erl_anno_SUITE.erl
+++ b/lib/stdlib/test/erl_anno_SUITE.erl
@@ -89,7 +89,6 @@ is_anno(_Config) ->
false = erl_anno:is_anno([{generated,true}]),
false = erl_anno:is_anno([{location,1},{file,nofile}]),
false = erl_anno:is_anno([{location,1},{text,notext}]),
- false = erl_anno:is_anno([{location,1},{text,[a,b,c]}]),
true = erl_anno:is_anno(erl_anno:new(1)),
A0 = erl_anno:new({1, 17}),
diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl
index a88843bb6e..fff6b11a38 100644
--- a/lib/stdlib/test/ets_SUITE.erl
+++ b/lib/stdlib/test/ets_SUITE.erl
@@ -3061,13 +3061,13 @@ time_lookup(Config) when is_list(Config) ->
"~p ets lookups/s",[Values]))}.
time_lookup_do(Opts) ->
- ?line Tab = ets_new(foo,Opts),
- ?line fill_tab(Tab,foo),
- ?line ets:insert(Tab,{{a,key},foo}),
- ?line {Time,_} = ?t:timecall(test_server,do_times,
- [10000,ets,lookup,[Tab,{a,key}]]),
- ?line true = ets:delete(Tab),
- round(10000 / Time). % lookups/s
+ Tab = ets_new(foo,Opts),
+ fill_tab(Tab,foo),
+ ets:insert(Tab,{{a,key},foo}),
+ {Time,_} = ?t:timecall(test_server,do_times,
+ [100000,ets,lookup,[Tab,{a,key}]]),
+ true = ets:delete(Tab),
+ round(100000 / Time). % lookups/s
badlookup(doc) ->
["Check proper return values from bad lookups in existing/non existing "
diff --git a/lib/stdlib/test/io_proto_SUITE.erl b/lib/stdlib/test/io_proto_SUITE.erl
index 858a78b1d2..78432789cd 100644
--- a/lib/stdlib/test/io_proto_SUITE.erl
+++ b/lib/stdlib/test/io_proto_SUITE.erl
@@ -482,7 +482,7 @@ unicode_options_gen(Config) when is_list(Config) ->
PrivDir = ?config(priv_dir, Config),
AllModes = [utf8,utf16,{utf16,big},{utf16,little},
utf32,{utf32,big},{utf32,little}],
- FSize = 17*1024,
+ FSize = 9*1024,
NumItersRead = 2,
NumItersWrite = 2,
Dir = filename:join(PrivDir, "GENDATA1"),
diff --git a/lib/stdlib/test/rand_SUITE.erl b/lib/stdlib/test/rand_SUITE.erl
index 9a1f37aa75..39ce1bd89a 100644
--- a/lib/stdlib/test/rand_SUITE.erl
+++ b/lib/stdlib/test/rand_SUITE.erl
@@ -33,7 +33,7 @@
-include_lib("test_server/include/test_server.hrl").
% Default timetrap timeout (set in init_per_testcase).
--define(default_timeout, ?t:minutes(1)).
+-define(default_timeout, ?t:minutes(3)).
-define(LOOP, 1000000).
init_per_testcase(_Case, Config) ->
diff --git a/lib/stdlib/test/unicode_SUITE.erl b/lib/stdlib/test/unicode_SUITE.erl
index 613be99ccd..9f5d485df6 100644
--- a/lib/stdlib/test/unicode_SUITE.erl
+++ b/lib/stdlib/test/unicode_SUITE.erl
@@ -87,8 +87,9 @@ ex_binaries_errors_utf8(Config) when is_list(Config) ->
%% Now, try with longer binary (trapping)
BrokenPart = list_to_binary(lists:seq(128,255)),
BrokenSz = byte_size(BrokenPart),
+ Seq255 = lists:seq(1,255),
[ begin
- OKList = lists:flatten(lists:duplicate(N,lists:seq(1,255))),
+ OKList = lists:flatten(lists:duplicate(N,Seq255)),
OKBin = unicode:characters_to_binary(OKList),
OKLen = length(OKList),
%% Copy to avoid that the binary get's writable
diff --git a/lib/stdlib/vsn.mk b/lib/stdlib/vsn.mk
index f57f31c8de..a1f2a946b1 100644
--- a/lib/stdlib/vsn.mk
+++ b/lib/stdlib/vsn.mk
@@ -1 +1 @@
-STDLIB_VSN = 2.4
+STDLIB_VSN = 2.5
diff --git a/lib/syntax_tools/doc/overview.edoc b/lib/syntax_tools/doc/overview.edoc
index df02ad0b3a..3111633a99 100644
--- a/lib/syntax_tools/doc/overview.edoc
+++ b/lib/syntax_tools/doc/overview.edoc
@@ -2,79 +2,34 @@
Syntax Tools overview page
-
@author Richard Carlsson <[email protected]>
-@copyright 1997-2004 Richard Carlsson
+@copyright 1997-2014 Richard Carlsson
@version {@version}
-@title Erlang Syntax Tools
+@title Erlang Syntax and Metaprogramming tools
-@doc This package contains modules for handling abstract Erlang syntax
-trees, in a way that is compatible with the "parse trees" of the
-standard library module `erl_parse', together with utilities for reading
-source files in unusual ways and pretty-printing syntax trees. Also
-included is an amazing module merger and renamer called Igor, as well as
-an automatic code-cleaner.
+@doc This package contains modules for handling abstract syntax trees (ASTs)
+in Erlang, in a way that is compatible with the "abstract format" parse
+trees of the stdlib module `erl_parse', together with utilities for reading
+source files, {@link erl_prettypr. pretty-printing syntax trees}, {@link
+igor. merging and renaming modules}, {@link erl_tidy. cleaning up obsolete
+constructs}, and doing {@link merl. metaprogramming} in Erlang.
-<p>The abstract layer (defined in {@link erl_syntax}) is nicely
+The abstract layer (defined in {@link erl_syntax}) is nicely
structured and the node types are context-independent. The layer makes
it possible to transparently attach source-code comments and user
annotations to nodes of the tree. Using the abstract layer makes
applications less sensitive to changes in the {@link //stdlib/erl_parse}
-data structures, only requiring the {@link erl_syntax} module to be
-up-to-date.</p>
+data structures, only requiring the `erl_syntax' module to be up-to-date.
-<p>The pretty printer {@link erl_prettypr} is implemented on top of the
+The pretty printer {@link erl_prettypr} is implemented on top of the
library module {@link prettypr}: this is a powerful and flexible generic
-pretty printing library, which is also distributed separately.</p>
-
-<p>For a short demonstration of parsing and pretty-printing, simply
-compile the included module <a
-href="../examples/demo.erl"><code>demo.erl</code></a>, and execute
-<code>demo:run()</code> from the Erlang shell. It will compile the
-remaining modules and give you further instructions.</p>
-
-<p>Also try the {@link erl_tidy} module, as follows:
-<pre>
- erl_tidy:dir("any-erlang-source-dir", [test, old_guard_tests]).</pre>
-("<code>test</code>" assures that no files are modified).</p>
-
-<p>News in 1.4:
-<ul>
- <li>Added support for {@link erl_syntax:cond_expr/1. cond-expressions},
- {@link erl_syntax:try_expr/4. try-expressions} and
- {@link erl_syntax:class_qualifier/2. class-qualifier patterns}.</li>
- <li>Added support for parameterized modules.</li>
- <li>{@link igor. Igor} is officially included.</li>
- <li>Quick-parse functionality added to {@link epp_dodger}.</li>
-</ul>
-</p>
-
-<p>News in 1.3:
-<ul>
- <li>Added support for qualified names (as used by "packages").</li>
- <li>Various internal changes.</li>
-</ul>
-</p>
+pretty printing library, which is also distributed separately.
-<p>News in 1.2:
-<ul>
- <li>HTML Documentation (generated with EDoc).</li>
- <li>A few bug fixes and some minor interface changes (sorry for any
- inconvenience).</li>
-</ul>
-</p>
+For a short demonstration of parsing and pretty-printing, simply
+compile the included module <a href="../examples/demo.erl">`demo.erl'</a>,
+and execute `demo:run()' from the Erlang shell. It will compile the
+remaining modules and give you further instructions.
-<p>News in 1.1:
-<ul>
- <li>Module {@link erl_tidy}: check or tidy either a single module, or a
- whole directory tree recursively. Rewrites and reformats the code
- without losing comments or expanding macros. Safe mode allows
- generating reports without modifying files.</li>
- <li>Module {@link erl_syntax_lib}: contains support functions for easier
- analysis of the source code structure.</li>
- <li>Module {@link epp_dodger}: Bypasses the Erlang preprocessor - avoids
- macro expansion, file inclusion, conditional compilation, etc.
- Allows you to find/modify particular definitions/applications of
- macros, and other things previously not possible.</li>
-</ul>
-</p>
+Also try the {@link erl_tidy} module, as follows:
+```erl_tidy:dir("any-erlang-source-dir", [test, old_guard_tests]).'''
+(the `test' option assures that no files are modified).
diff --git a/lib/syntax_tools/doc/src/Makefile b/lib/syntax_tools/doc/src/Makefile
index 2502bf877a..b7c599a9b9 100644
--- a/lib/syntax_tools/doc/src/Makefile
+++ b/lib/syntax_tools/doc/src/Makefile
@@ -50,6 +50,8 @@ XML_REF3_FILES = \
erl_syntax_lib.xml \
erl_tidy.xml \
igor.xml \
+ merl.xml \
+ merl_transform.xml \
prettypr.xml
XML_PART_FILES = part.xml part_notes.xml
diff --git a/lib/syntax_tools/doc/src/ref_man.xml b/lib/syntax_tools/doc/src/ref_man.xml
index 598f656011..2b114c8528 100644
--- a/lib/syntax_tools/doc/src/ref_man.xml
+++ b/lib/syntax_tools/doc/src/ref_man.xml
@@ -29,12 +29,11 @@
</header>
<description>
<p><em>Syntax_Tools</em> contains modules for handling abstract
- Erlang syntax trees, in a way that is compatible with the "parse
- trees" of the STDLIB module <c>erl_parse</c>, together with
- utilities for reading source files in unusual ways and
- pretty-printing syntax trees. Also included is an amazing module
- merger and renamer called Igor, as well as an automatic
- code-cleaner.</p>
+ Erlang syntax trees, in a way that is compatible with the "external
+ format" parse trees of the STDLIB module <c>erl_parse</c>, together
+ with utilities for reading source files, pretty-printing syntax trees,
+ merging and renaming modules, cleaning up obsolete constructs, and
+ doing metaprogramming in Erlang.</p>
</description>
<xi:include href="epp_dodger.xml"/>
<xi:include href="erl_comment_scan.xml"/>
@@ -44,6 +43,8 @@
<xi:include href="erl_syntax_lib.xml"/>
<xi:include href="erl_tidy.xml"/>
<xi:include href="igor.xml"/>
+ <xi:include href="merl.xml"/>
+ <xi:include href="merl_transform.xml"/>
<xi:include href="prettypr.xml"/>
</application>
diff --git a/lib/syntax_tools/examples/merl/Makefile b/lib/syntax_tools/examples/merl/Makefile
new file mode 100644
index 0000000000..13a9703733
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/Makefile
@@ -0,0 +1,22 @@
+EBIN=../../ebin
+INCLUDES=../../include
+SOURCES=merl_build.erl lisp.erl lispc.erl basic.erl basicc.erl
+HEADERS=$(INCLUDES)/merl.hrl
+OBJECTS=$(SOURCES:%.erl=%.beam)
+ERLC_FLAGS=+debug_info -I$(INCLUDES) -pa $(EBIN)
+
+all: $(OBJECTS) test
+
+%.beam: %.erl $(HEADERS) Makefile
+ erlc $(ERLC_FLAGS) -o ./ $<
+
+# additional dependencies due to the parse transform
+lispc.beam basicc.beam: $(EBIN)/merl_transform.beam $(EBIN)/merl.beam
+
+clean:
+ -rm -f $(OBJECTS)
+
+test:
+ erl -noshell -pa $(EBIN) \
+ -eval 'eunit:test([lisp, lispc, basic, basicc],[])' \
+ -s init stop
diff --git a/lib/syntax_tools/examples/merl/basic.erl b/lib/syntax_tools/examples/merl/basic.erl
new file mode 100644
index 0000000000..9030059d11
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/basic.erl
@@ -0,0 +1,77 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012 Richard Carlsson
+%% @doc Trivial Basic interpreter in Erlang
+
+-module(basic).
+
+-export([run/2]).
+
+-include_lib("eunit/include/eunit.hrl").
+
+-define(INTERPRETED, true).
+-include("basic_test.erl").
+
+run(N, Prog) ->
+ ets:new(var, [private, named_table]),
+ ets:new(line, [private, named_table, ordered_set]),
+ lists:foreach(fun (T) -> ets:insert(line, T) end, Prog),
+ goto(N).
+
+stop(N) ->
+ ets:delete(var),
+ ets:delete(line),
+ N.
+
+goto('$end_of_table') -> stop(0);
+goto(L) ->
+ L1 = ets:next(line, L),
+ %% user-supplied line numbers might not exist
+ case ets:lookup(line, L) of
+ [{_, X}] ->
+ stmt(X, L1);
+ _ ->
+ goto(L1)
+ end.
+
+stmt({print, S, As}, L) -> io:format(S, [expr(A) || A <- As]), goto(L);
+stmt({set, V, X}, L) -> ets:insert(var, {V, expr(X)}), goto(L);
+stmt({goto, X}, _L) -> goto(expr(X));
+stmt({stop, X}, _L) -> stop(expr(X));
+stmt({iff, X, A, B}, _L) ->
+ case expr(X) of
+ 0 -> goto(B);
+ _ -> goto(A)
+ end.
+
+expr(X) when is_number(X) ; is_list(X) ->
+ X;
+expr(X) when is_atom(X) ->
+ case ets:lookup(var, X) of
+ [] -> 0;
+ [{_,V}] -> V
+ end;
+expr({plus, X, Y}) ->
+ expr(X) + expr(Y);
+expr({equal, X, Y}) ->
+ bool(expr(X) == expr(Y));
+expr({gt, X, Y}) ->
+ bool(expr(X) > expr(Y));
+expr({knot, X}) ->
+ case expr(X) of
+ 0 -> 1;
+ _ -> 0
+ end.
+
+bool(true) -> 1;
+bool(false) -> 0.
diff --git a/lib/syntax_tools/examples/merl/basic_test.erl b/lib/syntax_tools/examples/merl/basic_test.erl
new file mode 100644
index 0000000000..ff35de6325
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/basic_test.erl
@@ -0,0 +1,77 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012 Richard Carlsson
+%% @doc Tests. For including in another module.
+
+%-module(basic_test).
+%-import(basic, run/1)
+
+-export([basic_fib/1]).
+
+-include_lib("eunit/include/eunit.hrl").
+
+basics_test_() ->
+ [?_assertEqual(42, run(1,[{1,{stop, 42}}])),
+ ?_assertEqual("hello", run(1,[{1,{stop,"hello"}}])),
+ ?_assertEqual(0, run(1,[{1,{print, "hello ~w", [42]}}])),
+ ?_assertEqual(5, run(1,[{1,{stop, {plus, 2, 3}}}])),
+ ?_assertEqual(5, run(1,[{1,{stop,{plus, 8, -3}}}])),
+ ?_assertEqual(0, run(1,[{1,{stop,{equal, 0, 1}}}])),
+ ?_assertEqual(1, run(1,[{1,{stop,{equal, 1, 1}}}])),
+ ?_assertEqual(0, run(1,[{1,{stop,{gt, 0, 1}}}])),
+ ?_assertEqual(0, run(1,[{1,{stop,{gt, 1, 1}}}])),
+ ?_assertEqual(1, run(1,[{1,{stop,{gt, 2, 1}}}])),
+ ?_assertEqual(0, run(1,[{1,{stop,{knot, 42}}}])),
+ ?_assertEqual(1, run(1,[{1,{stop,{knot, 0}}}])),
+ ?_assertEqual(42, run(1,[{1,{set, x, 42}}, {2,{stop,x}}])),
+ ?_assertEqual(17, run(1,[{1,{iff, 1, 2, 3}},
+ {2,{stop, 17}},
+ {3,{stop, 42}}])),
+ ?_assertEqual(42, run(1,[{1,{iff, 0, 2, 3}},
+ {2,{stop, 17}},
+ {3,{stop, 42}}])),
+ ?_assertEqual(17, run(1,[{1,{iff, 1, 2, 3}},
+ {2,{stop, 17}},
+ {3,{stop, -1}}])),
+ ?_assertEqual(42, run(1,[{1,{iff, 0, 2, 3}},
+ {2,{stop, -1}},
+ {3,{stop, 42}}]))
+
+
+ ].
+
+
+fib_test_() ->
+ [?_assertEqual(fib(N), basic_fib(N)) || N <- lists:seq(1,15)
+ ].
+
+
+fib(N) when N > 1 ->
+ fib(N-1) + fib(N-2);
+fib(_) ->
+ 1.
+
+basic_fib(N) ->
+ run(1,
+ [{1,{set,x,0}},
+ {2,{set,a,1}},
+ {3,{set,b,0}},
+ {10,{iff, {equal, x, N}, 20, 30}},
+ {20,{stop,a}},
+ {30,{print,"~w, ~w, ~w\n",[x,a,b]}},
+ {31,{set,t,a}},
+ {32,{set,a,{plus,a,b}}},
+ {33,{set,b,t}},
+ {34,{set,x,{plus,x,1}}},
+ {40,{goto,10}}
+ ]).
diff --git a/lib/syntax_tools/examples/merl/basicc.erl b/lib/syntax_tools/examples/merl/basicc.erl
new file mode 100644
index 0000000000..531ac51538
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/basicc.erl
@@ -0,0 +1,149 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012 Richard Carlsson
+%% @doc Basic compiler in Erlang.
+
+-module(basicc).
+
+-export([run/2, make_lines/1, bool/1]).
+
+-include_lib("eunit/include/eunit.hrl").
+
+-define(INTERPRETED, true).
+-include("basic_test.erl").
+
+-include("merl.hrl").
+
+run(N, Prog) ->
+ compile(Prog, tmp),
+ tmp:run(N, Prog).
+
+make_lines(Prog) ->
+ ets:new(line, [private, named_table, ordered_set]),
+ lists:foreach(fun ({L,_}) -> ets:insert(line, {L,label(L)}) end, Prog).
+
+compile(Prog, ModName) ->
+ make_lines(Prog),
+ Fs0 = lists:map(fun ({L, X}) ->
+ {true, label(L),
+ case stmt(X) of
+ {Stmt, false} ->
+ [?Q("() -> _@Stmt")];
+ {Stmt, true} ->
+ Next = case ets:next(line, L) of
+ '$end_of_table' ->
+ ?Q("stop(0)");
+ L1 ->
+ Label = label(L1),
+ ?Q("_@Label@()")
+ end,
+ [?Q("() -> _@Stmt, _@Next")]
+ end}
+ end, Prog),
+ ets:delete(line),
+ Run = ?Q(["(N, Prog) ->",
+ " ets:new(var, [private, named_table]),",
+ " basicc:make_lines(Prog),",
+ " goto(N)"
+ ]),
+ Stop = ?Q(["(R) ->",
+ " ets:delete(var),",
+ " ets:delete(line),",
+ " R"
+ ]),
+ Goto = ?Q(["(L) ->",
+ " case ets:lookup(line, L) of",
+ " [{_, X}] -> apply(tmp, X, []);",
+ " _ ->",
+ " case ets:next(line, L) of",
+ " '$end_of_table' -> stop(0);",
+ " L1 -> goto(L1)",
+ " end",
+ " end"]),
+ Fs = [{true, run, [Run]},
+ {false, stop, [Stop]},
+ {true, goto, [Goto]}
+ | Fs0],
+ Forms = merl_build:module_forms(
+ lists:foldl(fun ({X, Name, Cs}, S) ->
+ merl_build:add_function(X, Name, Cs, S)
+ end,
+ merl_build:init_module(ModName),
+ Fs)),
+ %% %% Write source to file for debugging
+ %% file:write_file(lists:concat([ModName, "_gen.erl"]),
+ %% erl_prettypr:format(erl_syntax:form_list(Forms),
+ %% [{paper,160},{ribbon,80}])),
+ merl:compile_and_load(Forms, [verbose]).
+
+label(L) ->
+ list_to_atom("label_" ++ integer_to_list(L)).
+
+stmt({print, S, As}) ->
+ Exprs = [expr(A) || A <- As],
+ {[?Q(["io:format(_@S@, [_@Exprs])"])], true};
+stmt({set, V, X}) ->
+ Expr = expr(X),
+ {[?Q(["ets:insert(var, {_@V@, _@Expr})"])], true};
+stmt({goto, X}) ->
+ {[jump(X)], false};
+stmt({stop, X}) ->
+ Expr = expr(X),
+ {[?Q(["stop(_@Expr)"])], false};
+stmt({iff, X, A, B}) ->
+ Cond = expr(X),
+ True = jump(A),
+ False = jump(B),
+ {?Q(["case _@Cond of",
+ " 0 -> _@False;",
+ " _ -> _@True",
+ "end"]),
+ false}.
+
+jump(X) ->
+ case ets:lookup(line, X) of
+ [{_, F}] ->
+ ?Q(["_@F@()"]);
+ true ->
+ Expr = expr(X),
+ [?Q(["goto(_@Expr)"])]
+ end.
+
+expr(X) when is_number(X) ; is_list(X) ->
+ ?Q("_@X@");
+expr(X) when is_atom(X) ->
+ ?Q(["case ets:lookup(var, _@X@) of",
+ " [] -> 0;",
+ " [{_,V}] -> V",
+ "end"]);
+expr({plus, X, Y}) ->
+ ExprX = expr(X),
+ ExprY = expr(Y),
+ ?Q("_@ExprX + _@ExprY");
+expr({equal, X, Y}) ->
+ ExprX = expr(X),
+ ExprY = expr(Y),
+ ?Q("basicc:bool(_@ExprX == _@ExprY)");
+expr({gt, X, Y}) ->
+ ExprX = expr(X),
+ ExprY = expr(Y),
+ ?Q("basicc:bool(_@ExprX > _@ExprY)");
+expr({knot, X}) ->
+ Expr = expr(X),
+ ?Q(["case _@Expr of",
+ " 0 -> 1;",
+ " _ -> 0",
+ "end"]).
+
+bool(true) -> 1;
+bool(false) -> 0.
diff --git a/lib/syntax_tools/examples/merl/lisp.erl b/lib/syntax_tools/examples/merl/lisp.erl
new file mode 100644
index 0000000000..371dc6b261
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/lisp.erl
@@ -0,0 +1,160 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012 Richard Carlsson
+%% @doc Trivial Lisp interpreter in Erlang.
+
+-module(lisp).
+
+-export([eval/1]).
+
+-export([init/0, equal/2, gt/2, knot/1]).
+
+-record(st, {env}).
+
+-define(INTERPRETED, true).
+-include("lisp_test.erl").
+
+eval(P) ->
+ {X, _} = eval(P, init()),
+ X.
+
+init() ->
+ Env = [{print, {builtin, fun do_print/2}}
+ ,{list, {builtin, fun do_list/2}}
+ ,{apply, {builtin, fun do_apply/2}}
+ ,{plus, {builtin, fun do_plus/2}}
+ ,{equal, {builtin, fun do_equal/2}}
+ ,{gt, {builtin, fun do_gt/2}}
+ ,{knot, {builtin, fun do_knot/2}}
+ ,{y, y()}
+ ],
+ #st{env=dict:from_list(Env)}.
+
+eval([lambda, Ps, B], #st{env=E}=St) when is_list(Ps) ->
+ case lists:all(fun is_atom/1, Ps) andalso
+ (length(Ps) =:= length(lists:usort(Ps))) of
+ true -> {{lambda, Ps, B, E}, St};
+ false -> throw(bad_lambda)
+ end;
+eval([lambda | _], _) ->
+ throw(bad_lambda);
+eval([def, A, V, B], #st{env=E0}=St) when is_atom(A) ->
+ {V1, St1} = eval(V, St),
+ E1 = bind(A, V1, E0),
+ {X, St2} = eval(B, St1#st{env=E1}),
+ {X, St2#st{env=E0}};
+eval([def | _], _) ->
+ throw(bad_def);
+eval([quote, A], St) ->
+ {A, St};
+eval([quote | _], _) ->
+ throw(bad_quote);
+eval([iff, X, A, B], St) ->
+ case eval(X, St) of
+ {[], St1} -> eval(B, St1);
+ {_, St1} -> eval(A, St1)
+ end;
+eval([do], _St0) ->
+ throw(bad_do);
+eval([do | As], St0) ->
+ lists:foldl(fun (X, {_,St}) -> eval(X, St) end, {[],St0}, As);
+eval([_|_]=L, St) ->
+ {[F | As], St1} = lists:mapfoldl(fun eval/2, St, L),
+ call(F, As, St1);
+eval(A, St) when is_atom(A) ->
+ {deref(A, St), St};
+eval(C, St) ->
+ {C, St}.
+
+%% UTILITY FUNCTIONS
+
+deref(A, #st{env=E}) ->
+ case dict:find(A, E) of
+ {ok, V} -> V;
+ error -> throw({undefined, A})
+ end.
+
+bind(A, V, E) ->
+ dict:store(A, V, E).
+
+bind_args([P | Ps], [A | As], E) ->
+ bind_args(Ps, As, dict:store(P, A, E));
+bind_args([], [], E) ->
+ E;
+bind_args(_, _, _) ->
+ throw(bad_arity).
+
+call({lambda, Ps, B, E}, As, #st{env=E0}=St) ->
+ {X, St1} = eval(B, St#st{env=bind_args(Ps, As, E)}),
+ {X, St1#st{env=E0}};
+call({builtin, F}, As, St) ->
+ F(As, St);
+call(X, _, _) ->
+ throw({bad_fun, X}).
+
+bool(true) -> 1;
+bool(false) -> [].
+
+%% BUILTINS
+
+y() ->
+ {Y, _} = eval([lambda, [f],
+ [[lambda, [x], [f, [lambda, [y], [[x, x], y]]]],
+ [lambda, [x], [f, [lambda, [y], [[x, x], y]]]]]],
+ #st{env=dict:new()}),
+ Y.
+
+do_print([S | Xs], St) ->
+ io:format(S, Xs),
+ {[], St};
+do_print(_, _) ->
+ throw(bad_print).
+
+do_list(As, St) ->
+ {As, St}.
+
+do_apply([F, As], St) ->
+ call(F, As, St);
+do_apply(_, _) ->
+ throw(bad_apply).
+
+do_plus([X, Y], St) when is_number(X), is_number(Y) ->
+ {X + Y, St};
+do_plus(As, _) ->
+ throw({bad_plus, As}).
+
+do_equal([X, Y], St) ->
+ {equal(X, Y), St};
+do_equal(As, _) ->
+ throw({bad_equal, As}).
+
+equal(X, Y) ->
+ bool(X =:= Y).
+
+do_gt([X, Y], St) ->
+ {gt(X, Y), St};
+do_gt(As, _) ->
+ throw({bad_gt, As}).
+
+gt(X, Y) ->
+ bool(X > Y).
+
+do_knot([X], St) ->
+ {knot(X), St};
+do_knot(As, _) ->
+ throw({bad_gt, As}).
+
+knot([]) ->
+ 1;
+knot(_) ->
+ [].
diff --git a/lib/syntax_tools/examples/merl/lisp_test.erl b/lib/syntax_tools/examples/merl/lisp_test.erl
new file mode 100644
index 0000000000..cab8134b8f
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/lisp_test.erl
@@ -0,0 +1,98 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012 Richard Carlsson
+%% @doc Tests. For including in another module.
+
+%-module(lisp_test).
+%-import(lisp, eval/1)
+
+-export([fib/1, lisp_fib/1]).
+
+-include_lib("eunit/include/eunit.hrl").
+
+basics_test_() ->
+ [?_assertEqual(42, eval(42)),
+ ?_assertEqual("hello", eval([quote, "hello"])),
+ ?_assertEqual(print, eval([quote, print])),
+ ?_assertMatch([17,[1,2],42], eval([list,17,[list,1,2],42])),
+ ?_assertEqual([], eval([print, [quote, "hello ~w"], [list, 42]])),
+ ?_assertEqual(5, eval([plus, 2, 3])),
+ ?_assertEqual(5, eval([plus, 8, -3])),
+ ?_assertEqual([], eval([equal, 0, 1])),
+ ?_assertEqual(1, eval([equal, 1, 1])),
+ ?_assertEqual([], eval([gt, 0, 1])),
+ ?_assertEqual([], eval([gt, 1, 1])),
+ ?_assertEqual(1, eval([gt, 2, 1])),
+ ?_assertEqual([], eval([knot, 42])),
+ ?_assertEqual(1, eval([knot, []])),
+ ?_assertEqual(42, eval([do, 17, 42])),
+ ?_assertEqual([], eval([apply, print, [quote, ["~p", [42]]]])),
+ ?_assertEqual(42, eval([iff, [], 17, 42])),
+ ?_assertEqual(17, eval([iff, 1, 17, 42])),
+ ?_assertEqual(42, eval([iff, [], [apply], 42])),
+ ?_assertEqual(17, eval([iff, 1, 17, [apply]])),
+ ?_assertEqual(17, eval([def, foo, 17, foo])),
+ ?_assertEqual(17, eval([def, bar, 42, [def, foo, 17, foo]])),
+ ?_assertEqual(42, eval([def, bar, 42, [def, foo, 17, bar]])),
+ ?_assertEqual(17, eval([def, foo, 42, [def, foo, 17, foo]]))
+ ].
+
+-ifdef(INTERPRETED).
+interpreter_basics_test_() ->
+ [?_assertThrow({undefined, foo}, eval(foo)),
+ ?_assertMatch({builtin,_}, eval(print)),
+ ?_assertThrow(bad_do, eval([do])),
+ ?_assertThrow(bad_apply, eval([apply])),
+ ?_assertThrow({undefined, foo}, eval([def, bar, 17, foo]))
+ ].
+
+interpreter_lambda_test_() ->
+ [?_assertMatch({lambda,_,_,_}, eval([lambda, [], 42])),
+ ?_assertMatch({lambda,_,_,_}, eval([lambda, [x], x])),
+ ?_assertMatch({lambda,_,_,_}, eval([lambda, [x,y], 42]))
+ ].
+-endif.
+
+lambda_test_() ->
+ [?_assertThrow(bad_lambda, eval([lambda])),
+ ?_assertThrow(bad_lambda, eval([lambda, []])),
+ ?_assertThrow(bad_lambda, eval([lambda, [], 17, 42])),
+ ?_assertThrow(bad_lambda, eval([lambda, 17, 42])),
+ ?_assertThrow(bad_lambda, eval([lambda, [17], 42])),
+ ?_assertThrow(bad_lambda, eval([lambda, [foo, foo], 42])),
+ ?_assertEqual(42, eval([[lambda, [x], x], 42])),
+ ?_assertEqual([42, 17], eval([[lambda, [x], [list, x, 17]], 42])),
+ ?_assertEqual([42, 17], eval([def, f, [def, y, 42,
+ [lambda, [x], [list, y, x]]],
+ [f, 17]]))
+ ].
+
+fib_test_() ->
+ [?_assertEqual(fib(N), lisp_fib(N)) || N <- lists:seq(1,15)
+ ].
+
+
+fib(N) when N > 1 ->
+ fib(N-1) + fib(N-2);
+fib(_) ->
+ 1.
+
+lisp_fib(N) ->
+ eval([def, fib,
+ [y, [lambda, [f], [lambda, [x],
+ [iff, [gt, x, 1],
+ [plus, [f, [plus,x,-1]], [f, [plus,x,-2]]],
+ 1]
+ ]]],
+ [fib, N]
+ ]).
diff --git a/lib/syntax_tools/examples/merl/lispc.erl b/lib/syntax_tools/examples/merl/lispc.erl
new file mode 100644
index 0000000000..97072cdab7
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/lispc.erl
@@ -0,0 +1,102 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012 Richard Carlsson
+%% @doc Lisp compiler in Erlang.
+
+-module(lispc).
+
+-export([eval/1]).
+
+-record(st, {}).
+
+-include("lisp_test.erl").
+
+-include("merl.hrl").
+
+eval(Lisp) ->
+ compile(Lisp, tmp),
+ tmp:eval().
+
+compile(Lisp, ModName) ->
+ {Code, _} = gen(Lisp, #st{}),
+ Main = ?Q(["() ->",
+ " __print = fun (S, Xs) -> io:format(S,Xs), [] end,",
+ " __apply = fun erlang:apply/2,",
+ " __plus = fun erlang:'+'/2,",
+ " __equal = fun lisp:equal/2,",
+ " __gt = fun lisp:gt/2,",
+ " __knot = fun lisp:knot/1,",
+ " __y = fun (F) ->",
+ " (fun (X) -> F(fun (Y) -> (X(X))(Y) end) end)",
+ " (fun (X) -> F(fun (Y) -> (X(X))(Y) end) end)",
+ " end,",
+ " _@Code"]),
+ Forms = merl_build:module_forms(
+ merl_build:add_function(true, eval, [Main],
+ merl_build:init_module(ModName))),
+ %% %% Write source to file for debugging
+ %% file:write_file(lists:concat([ModName, "_gen.erl"]),
+ %% erl_prettypr:format(erl_syntax:form_list(Forms),
+ %% [{paper,160},{ribbon,80}])),
+ merl:compile_and_load(Forms, [verbose]).
+
+var(Atom) ->
+ merl:var(list_to_atom("__" ++ atom_to_list(Atom))).
+
+gen([lambda, Ps, B], St) when is_list(Ps) ->
+ case lists:all(fun is_atom/1, Ps) andalso
+ (length(Ps) =:= length(lists:usort(Ps))) of
+ true ->
+ Vars = [var(P) || P <- Ps],
+ {Body, St1} = gen(B, St),
+ {?Q("fun (_@Vars) -> _@Body end"), St1};
+ false ->
+ throw(bad_lambda)
+ end;
+gen([lambda | _], _) ->
+ throw(bad_lambda);
+gen([def, A, V, B], St) when is_atom(A) ->
+ Var = var(A),
+ {Val, St1} = gen(V, St),
+ {Body, St2} = gen(B, St1),
+ {?Q("(fun (_@Var) -> _@Body end)(_@Val)"), St2};
+gen([def | _], _) ->
+ throw(bad_def);
+gen([quote, A], St) ->
+ {merl:term(A), St};
+gen([quote | _], _) ->
+ throw(bad_quote);
+gen([iff, X, A, B], St) ->
+ {Cond, St1} = gen(X, St),
+ {True, St2} = gen(A, St1),
+ {False, St3} = gen(B, St2),
+ {?Q(["case _@Cond of",
+ " [] -> _@False;",
+ " _ -> _@True",
+ "end"]),
+ St3};
+gen([do], _) ->
+ throw(bad_do);
+gen([do | As], St0) ->
+ {Body, St1} = lists:mapfoldl(fun gen/2, St0, As),
+ {?Q("begin _@Body end"), St1};
+gen([list | As], St0) ->
+ {Elem, St1} = lists:mapfoldl(fun gen/2, St0, As),
+ {?Q("[ _@Elem ]"), St1};
+gen([_|_]=L, St) ->
+ {[F | As], St1} = lists:mapfoldl(fun gen/2, St, L),
+ {?Q("((_@F)(_@As))"), St1};
+gen(A, St) when is_atom(A) ->
+ {var(A), St};
+gen(C, St) ->
+ {merl:term(C), St}.
diff --git a/lib/syntax_tools/examples/merl/merl_build.erl b/lib/syntax_tools/examples/merl/merl_build.erl
new file mode 100644
index 0000000000..c539f8e2af
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/merl_build.erl
@@ -0,0 +1,104 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012 Richard Carlsson
+%% @doc Making it simple to build a module with merl
+
+-module(merl_build).
+
+-export([init_module/1, module_forms/1, add_function/4, add_record/3,
+ add_import/3, add_attribute/3, set_file/2]).
+
+-import(merl, [term/1]).
+
+-include("merl.hrl").
+
+-type filename() :: string().
+
+-record(module, { name :: atom()
+ , file :: filename()
+ , exports=[] :: [{atom(), integer()}]
+ , imports=[] :: [{atom(), [{atom(), integer()}]}]
+ , attributes=[] :: [{filename(), atom(), [term()]}]
+ , records=[] :: [{filename(), atom(),
+ [{atom(), merl:tree()}]}]
+ , functions=[] :: [{filename(), atom(), [merl:tree()]}]
+ }).
+
+%% TODO: init module from a list of forms (from various sources)
+
+%% @doc Create a new module representation, using the given module name.
+init_module(Name) when is_atom(Name) ->
+ %% use the module name as the default file name - better than nothing
+ #module{name=Name, file=atom_to_list(Name)}.
+
+%% @doc Get the list of syntax tree forms for a module representation. This can
+%% be passed to compile/2.
+module_forms(#module{name=Name,
+ exports=Xs,
+ imports=Is,
+ records=Rs,
+ attributes=As,
+ functions=Fs})
+ when is_atom(Name), Name =/= undefined ->
+ Module = ?Q("-module('@Name@')."),
+ Exported = [erl_syntax:arity_qualifier(term(N), term(A))
+ || {N,A} <- ordsets:from_list(Xs)],
+ Export = ?Q("-export(['@_Exported'/1])."),
+ Imports = [?Q("-import('@M@', ['@_NAs'/1]).")
+ || {M, Ns} <- Is,
+ NAs <- [[erl_syntax:arity_qualifier(term(N), term(A))
+ || {N,A} <- ordsets:from_list(Ns)]]
+ ],
+ Attrs = [?Q("-file(\"'@File@\",1). -'@N@'('@T@').")
+ || {File, N, T} <- lists:reverse(As)],
+ Records = [?Q("-file(\"'@File@\",1). -record('@N@',{'@_RFs'=[]}).")
+ || {File, N, Es} <- lists:reverse(Rs),
+ RFs <- [[erl_syntax:record_field(term(F), V)
+ || {F,V} <- Es]]
+ ],
+ Functions = [?Q("-file(\"'@File@\",1). '@_F'() -> [].")
+ || {File, N, Cs} <- lists:reverse(Fs),
+ F <- [erl_syntax:function(term(N), Cs)]],
+ lists:flatten([Module, Export, Imports, Attrs, Records, Functions]).
+
+%% @doc Set the source file name for all subsequently added functions,
+%% records, and attributes.
+set_file(Filename, #module{}=M) ->
+ M#module{file=filename:flatten(Filename)}.
+
+%% @doc Add a function to a module representation.
+add_function(Exported, Name, Clauses,
+ #module{file=File, exports=Xs, functions=Fs}=M)
+ when is_boolean(Exported), is_atom(Name), Clauses =/= [] ->
+ Arity = length(erl_syntax:clause_patterns(hd(Clauses))),
+ Xs1 = case Exported of
+ true -> [{Name,Arity} | Xs];
+ false -> Xs
+ end,
+ M#module{exports=Xs1, functions=[{File, Name, Clauses} | Fs]}.
+
+%% @doc Add a record declaration to a module representation.
+add_record(Name, Fields, #module{file=File, records=Rs}=M)
+ when is_atom(Name) ->
+ M#module{records=[{File, Name, Fields} | Rs]}.
+
+%% @doc Add a "wild" attribute, such as `-compile(Opts)' to a module
+%% representation. Note that such attributes can only have a single argument.
+add_attribute(Name, Term, #module{file=File, attributes=As}=M)
+ when is_atom(Name) ->
+ M#module{attributes=[{File, Name, Term} | As]}.
+
+%% @doc Add an import declaration to a module representation.
+add_import(From, Names, #module{imports=Is}=M)
+ when is_atom(From), is_list(Names) ->
+ M#module{imports=[{From, Names} | Is]}.
diff --git a/lib/syntax_tools/include/merl.hrl b/lib/syntax_tools/include/merl.hrl
new file mode 100644
index 0000000000..e44a78dece
--- /dev/null
+++ b/lib/syntax_tools/include/merl.hrl
@@ -0,0 +1,29 @@
+%% ---------------------------------------------------------------------
+%% Header file for merl
+%%
+%% 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.
+
+-ifndef(MERL_HRL).
+
+
+%% Quoting a piece of code
+-define(Q(Text), merl:quote(?LINE, Text)).
+
+%% Quasi-quoting code, substituting metavariables listed in Env
+-define(Q(Text, Env), merl:qquote(?LINE, Text, Env)).
+
+
+-ifndef(MERL_NO_TRANSFORM).
+-compile({parse_transform, merl_transform}).
+-endif.
+
+
+-endif.
diff --git a/lib/syntax_tools/src/Makefile b/lib/syntax_tools/src/Makefile
index c9fbad8f9a..2c565cee7f 100644
--- a/lib/syntax_tools/src/Makefile
+++ b/lib/syntax_tools/src/Makefile
@@ -22,6 +22,9 @@ RELSYSDIR = $(RELEASE_PATH)/lib/syntax_tools-$(VSN)
#
EBIN = ../ebin
+INCLUDE=../include
+
+ERL_COMPILE_FLAGS += -pa $(EBIN) -pa ./ -I$(INCLUDE)
ifeq ($(NATIVE_LIBS_ENABLED),yes)
ERL_COMPILE_FLAGS += +native
@@ -30,10 +33,15 @@ ERL_COMPILE_FLAGS += +nowarn_shadow_vars +warn_unused_import -Werror # +warn_mis
SOURCES=erl_syntax.erl erl_prettypr.erl erl_syntax_lib.erl \
erl_comment_scan.erl erl_recomment.erl erl_tidy.erl \
- epp_dodger.erl prettypr.erl igor.erl
+ epp_dodger.erl prettypr.erl igor.erl \
+ merl.erl merl_transform.erl
+
+INCLUDE_FILES = merl.hrl
OBJECTS=$(SOURCES:%.erl=$(EBIN)/%.$(EMULATOR)) $(APP_TARGET) $(APPUP_TARGET)
+INCLUDE_DELIVERABLES = $(INCLUDE_FILES:%=$(INCLUDE)/%)
+
APP_FILE= syntax_tools.app
APP_SRC= $(APP_FILE).src
APP_TARGET= $(EBIN)/$(APP_FILE)
@@ -52,6 +60,7 @@ all: $(OBJECTS)
clean:
+ rm -f ./merl_transform.beam
rm -f $(OBJECTS)
rm -f core *~
@@ -64,6 +73,14 @@ realclean: clean
$(EBIN)/%.$(EMULATOR):%.erl
$(erlc_verbose)erlc -W $(ERL_COMPILE_FLAGS) -o$(EBIN) $<
+# special rules and dependencies to apply the transform to itself
+$(EBIN)/merl_transform.beam: $(EBIN)/merl.beam ./merl_transform.beam \
+ ../include/merl.hrl
+./merl_transform.beam: ./merl_transform.erl $(EBIN)/merl.beam \
+ ../include/merl.hrl
+ $(V_ERLC) -DMERL_NO_TRANSFORM $(ERL_COMPILE_FLAGS) -o ./ $<
+
+
# ----------------------------------------------------
# Special Build Targets
# ----------------------------------------------------
@@ -84,6 +101,8 @@ release_spec: opt
$(INSTALL_DATA) $(OBJECTS) "$(RELSYSDIR)/ebin"
$(INSTALL_DIR) "$(RELSYSDIR)/src"
$(INSTALL_DATA) $(SOURCES) "$(RELSYSDIR)/src"
+ $(INSTALL_DIR) "$(RELSYSDIR)/include"
+ $(INSTALL_DATA) $(INCLUDE_DELIVERABLES) "$(RELSYSDIR)/include"
release_docs_spec:
diff --git a/lib/syntax_tools/src/merl.erl b/lib/syntax_tools/src/merl.erl
new file mode 100644
index 0000000000..690306c17b
--- /dev/null
+++ b/lib/syntax_tools/src/merl.erl
@@ -0,0 +1,1230 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% Note: EDoc uses @@ and @} as escape sequences, so in the doc text below,
+%% `@@' must be written `@@@@' and `@}' must be written `@@}'.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2010-2015 Richard Carlsson
+%%
+%% @doc Metaprogramming in Erlang.
+%% Merl is a more user friendly interface to the `erl_syntax' module, making
+%% it easy both to build new ASTs from scratch and to
+%% match and decompose existing ASTs. For details that are outside the scope
+%% of Merl itself, please see the documentation of {@link erl_syntax}.
+%%
+%% == Quick start ==
+%%
+%% To enable the full power of Merl, your module needs to include the Merl
+%% header file:
+%% ```-include_lib("syntax_tools/include/merl.hrl").'''
+%%
+%% Then, you can use the `?Q(Text)' macros in your code to create ASTs or match
+%% on existing ASTs. For example:
+%% ```Tuple = ?Q("{foo, 42}"),
+%% ?Q("{foo, _@Number}") = Tuple,
+%% Call = ?Q("foo:bar(_@Number)")'''
+%%
+%% Calling `merl:print(Call)' will then print the following code:
+%% ```foo:bar(42)'''
+%%
+%% The `?Q' macros turn the quoted code fragments into ASTs, and lifts
+%% metavariables such as `_@Tuple' and `_@Number' to the level of your Erlang
+%% code, so you can use the corresponding Erlang variables `Tuple' and `Number'
+%% directly. This is the most straightforward way to use Merl, and in many
+%% cases it's all you need.
+%%
+%% You can even write case switches using `?Q' macros as patterns. For example:
+%% ```case AST of
+%% ?Q("{foo, _@Foo}") -> handle(Foo);
+%% ?Q("{bar, _@Bar}") when erl_syntax:is_integer(Bar) -> handle(Bar);
+%% _ -> handle_default()
+%% end'''
+%%
+%% These case switches only allow `?Q(...)' or `_' as clause patterns, and the
+%% guards may contain any expressions, not just Erlang guard expressions.
+%%
+%% If the macro `MERL_NO_TRANSFORM' is defined before the `merl.hrl' header
+%% file is included, the parse transform used by Merl will be disabled, and in
+%% that case, the match expressions `?Q(...) = ...', case switches using
+%% `?Q(...)' patterns, and automatic metavariables like `_@Tuple' cannot be
+%% used in your code, but the Merl macros and functions still work. To do
+%% metavariable substitution, you need to use the `?Q(Text, Map)' macro, e.g.:
+%% ```Tuple = ?Q("{foo, _@bar, _@baz}", [{bar, Bar}, {baz,Baz}])'''
+%%
+%% The text given to a `?Q(Text)' macro can be either a single string, or a
+%% list of strings. The latter is useful when you need to split a long
+%% expression over multiple lines, e.g.:
+%% ```?Q(["case _@Expr of",
+%% " {foo, X} -> f(X);",
+%% " {bar, X} -> g(X)",
+%% " _ -> h(X)"
+%% "end"])'''
+%% If there is a syntax error somewhere in the text (like the missing semicolon
+%% in the second clause above) this allows Merl to generate an error message
+%% pointing to the exact line in your source code. (Just remember to
+%% comma-separate the strings in the list, otherwise Erlang will concatenate
+%% the string fragments as if they were a single string.)
+%%
+%% == Metavariable syntax ==
+%%
+%% There are several ways to write a metavariable in your quoted code:
+%% <ul>
+%% <li>Atoms starting with `@', for example `` '@foo' '' or `` '@Foo' ''</li>
+%% <li>Variables starting with `_@', for example `_@bar' or `_@Bar'</li>
+%% <li>Strings starting with ``"'@'', for example ``"'@File"''</li>
+%% <li>Integers starting with 909, for example `9091' or `909123'</li>
+%% </ul>
+%% Following the prefix, one or more `_' or `0' characters may be used to
+%% indicate "lifting" of the variable one or more levels, and after that, a `@'
+%% or `9' character indicates a glob metavariable (matching zero or more
+%% elements in a sequence) rather than a normal metavariable. For example:
+%% <ul>
+%% <li>`` '@_foo' '' is lifted one level, and `_@__foo' is lifted two
+%% levels</li>
+%% <li>`_@@@@bar' is a glob variable, and `_@_@bar' is a lifted glob
+%% variable</li>
+%% <li>`90901' is a lifted variable,`90991' is a glob variable, and `9090091'
+%% is a glob variable lifted two levels</li>
+%% </ul>
+%% (Note that the last character in the name is never considered to be a lift
+%% or glob marker, hence, `_@__' and `90900' are only lifted one level, not
+%% two. Also note that globs only matter for matching; when doing
+%% substitutions, a non-glob variable can be used to inject a sequence of
+%% elements, and vice versa.)
+%%
+%% If the name after the prefix and any lift and glob markers is `_' or `0',
+%% the variable is treated as an anonymous catch-all pattern in matches. For
+%% example, `_@_', `_@@@@_', `_@__', or even `_@__@_'.
+%%
+%% Finally, if the name without any prefixes or lift/glob markers begins with
+%% an uppercase character, as in `_@Foo' or `_@_@Foo', it will become a
+%% variable on the Erlang level, and can be used to easily deconstruct and
+%% construct syntax trees:
+%% ```case Input of
+%% ?Q("{foo, _@Number}") -> ?Q("foo:bar(_@Number)");
+%% ...'''
+%% We refer to these as "automatic metavariables". If in addition the name ends
+%% with `@', as in `_@Foo@', the value of the variable as an Erlang term will
+%% be automatically converted to the corresponding abstract syntax tree when
+%% used to construct a larger tree. For example, in:
+%% ```Bar = {bar, 42},
+%% Foo = ?Q("{foo, _@Bar@@}")'''
+%% (where Bar is just some term, not a syntax tree) the result `Foo' will be a
+%% syntax tree representing `{foo, {bar, 42}}'. This avoids the need for
+%% temporary variables in order to inject data, as in
+%% ```TmpBar = erl_syntax:abstract(Bar),
+%% Foo = ?Q("{foo, _@TmpBar}")'''
+%%
+%% If the context requires an integer rather than a variable, an atom, or a
+%% string, you cannot use the uppercase convention to mark an automatic
+%% metavariable. Instead, if the integer (without the `909'-prefix and
+%% lift/glob markers) ends in a `9', the integer will become an Erlang-level
+%% variable prefixed with `Q', and if it ends with `99' it will also be
+%% automatically abstracted. For example, the following will increment the
+%% arity of the exported function f:
+%% ```case Form of
+%% ?Q("-export([f/90919]).") ->
+%% Q2 = erl_syntax:concrete(Q1) + 1,
+%% ?Q("-export([f/909299]).");
+%% ...'''
+%%
+%% == When to use the various forms of metavariables ==
+%%
+%% Merl can only parse a fragment of text if it follows the basic syntactical
+%% rules of Erlang. In most places, a normal Erlang variable can be used as
+%% metavariable, for example:
+%% ```?Q("f(_@Arg)") = Expr'''
+%% but if you want to match on something like the name of a function, you have
+%% to use an atom as metavariable:
+%% ```?Q("'@Name'() -> _@@@@_." = Function'''
+%% (note the anonymous glob variable `_@@@@_' to ignore the function body).
+%%
+%% In some contexts, only a string or an integer is allowed. For example, the
+%% directive `-file(Name, Line)' requires that `Name' is a string literal and
+%% `Line' an integer literal:
+%%
+%% ```?Q("-file(\"'@File\", 9090).") = ?Q("-file(\"foo.erl\", 42).")).'''
+%% This will extract the string literal `"foo.erl"' into the variable `Foo'.
+%% Note the use of the anonymous variable `9090' to ignore the line number. To
+%% match and also bind a metavariable that must be an integer literal, we can
+%% use the convention of ending the integer with a 9, turning it into a
+%% Q-prefixed variable on the Erlang level (see the previous section).
+%%
+%% === Globs ===
+%%
+%% Whenever you want to match out a number of elements in a sequence (zero or
+%% more) rather than a fixed set of elements, you need to use a glob. For
+%% example:
+%% ```?Q("{_@@@@Elements}") = ?Q({a, b, c})'''
+%% will bind Elements to the list of individual syntax trees representing the
+%% atoms `a', `b', and `c'. This can also be used with static prefix and suffix
+%% elements in the sequence. For example:
+%% ```?Q("{a, b, _@@@@Elements}") = ?Q({a, b, c, d})'''
+%% will bind Elements to the list of the `c' and `d' subtrees, and
+%% ```?Q("{_@@@@Elements, c, d}") = ?Q({a, b, c, d})'''
+%% will bind Elements to the list of the `a' and `b' subtrees. You can even use
+%% plain metavariables in the prefix or suffix:
+%% ```?Q("{_@First, _@@@@Rest}") = ?Q({a, b, c})'''
+%% or
+%% ```?Q("{_@@@@_, _@Last}") = ?Q({a, b, c})'''
+%% (ignoring all but the last element). You cannot however have two globs as
+%% part of the same sequence.
+%%
+%% === Lifted metavariables ===
+%%
+%% In some cases, the Erlang syntax rules make it impossible to place a
+%% metavariable directly where you would like it. For example, you cannot
+%% write:
+%% ```?Q("-export([_@@@@Name]).")'''
+%% to match out all name/arity pairs in the export list, or to insert a list of
+%% exports in a declaration, because the Erlang parser only allows elements on
+%% the form `A/I' (where `A' is an atom and `I' an integer) in the export list.
+%% A variable like the above is not allowed, but neither is a single atom or
+%% integer, so `` '@@@@Name' '' or `909919' wouldn't work either.
+%%
+%% What you have to do in such cases is to write your metavariable in a
+%% syntactically valid position, and use lifting markers to denote where it
+%% should really apply, as in:
+%% ```?Q("-export(['@@_@@Name'/0]).")'''
+%% This causes the variable to be lifted (after parsing) to the next higher
+%% level in the syntax tree, replacing that entire subtree. In this case, the
+%% `` '@@_@@Name'/0 '' will be replaced with `` '@@@@Name' '', and the ``/0''
+%% part was just used as dummy notation and will be discarded.
+%%
+%% You may even need to apply lifting more than once. To match the entire
+%% export list as a single syntax tree, you can write:
+%% ```?Q("-export(['@@__Name'/0]).")'''
+%% using two underscores, but with no glob marker this time. This will make the
+%% entire ``['@@__Name'/0]'' part be replaced with `` '@@Name' ''.
+%%
+%% Sometimes, the tree structure of a code fragment isn't very obvious, and
+%% parts of the structure may be invisible when printed as source code. For
+%% instance, a simple function definition like the following:
+%% ```zero() -> 0.'''
+%% consists of the name (the atom `zero'), and a list of clauses containing the
+%% single clause `() -> 0'. The clause consists of an argument list (empty), a
+%% guard (empty), and a body (which is always a list of expressions) containing
+%% the single expression `0'. This means that to match out the name and the
+%% list of clauses of any function, you'll need to use a pattern like
+%% ``?Q("'@Name'() -> _@_@Body.")'', using a dummy clause whose body is a glob
+%% lifted one level.
+%%
+%% To visualize the structure of a syntax tree, you can use the function
+%% `merl:show(T)', which prints a summary. For example, entering
+%% ```merl:show(merl:quote("inc(X, Y) when Y > 0 -> X + Y."))'''
+%% in the Erlang shell will print the following (where the `+' signs separate
+%% groups of subtrees on the same level):
+%% ```function: inc(X, Y) when ... -> X + Y.
+%% atom: inc
+%% +
+%% clause: (X, Y) when ... -> X + Y
+%% variable: X
+%% variable: Y
+%% +
+%% disjunction: Y > 0
+%% conjunction: Y > 0
+%% infix_expr: Y > 0
+%% variable: Y
+%% +
+%% operator: >
+%% +
+%% integer: 0
+%% +
+%% infix_expr: X + Y
+%% variable: X
+%% +
+%% operator: +
+%% +
+%% variable: Y'''
+%%
+%% This shows another important non-obvious case: a clause guard, even if it's
+%% as simple as `Y > 0', always consists of a single disjunction of one or more
+%% conjunctions of tests, much like a tuple of tuples. Thus:
+%% <ul>
+%% <li>``"when _@Guard ->"'' will only match a guard with exactly one
+%% test</li>
+%% <li>``"when _@@@@Guard ->"'' will match a guard with one or more
+%% comma-separated tests (but no semicolons), binding `Guard' to the list
+%% of tests</li>
+%% <li>``"when _@_Guard ->"'' will match just like the previous pattern, but
+%% binds `Guard' to the conjunction subtree</li>
+%% <li>``"when _@_@Guard ->"'' will match an arbitrary nonempty guard,
+%% binding `Guard' to the list of conjunction subtrees</li>
+%% <li>``"when _@__Guard ->"'' will match like the previous pattern, but
+%% binds `Guard' to the whole disjunction subtree</li>
+%% <li>and finally, ``"when _@__@Guard ->"'' will match any clause,
+%% binding `Guard' to `[]' if the guard is empty and to `[Disjunction]'
+%% otherwise</li>
+%% </ul>
+%%
+%% Thus, the following pattern matches all possible clauses:
+%% ```"(_@@Args) when _@__@Guard -> _@@Body"'''
+%% @end
+
+-module(merl).
+
+-export([term/1, var/1, print/1, show/1]).
+
+-export([quote/1, quote/2, qquote/2, qquote/3]).
+
+-export([template/1, tree/1, subst/2, tsubst/2, alpha/2, match/2, switch/2]).
+
+-export([template_vars/1, meta_template/1]).
+
+-export([compile/1, compile/2, compile_and_load/1, compile_and_load/2]).
+
+%% NOTE: this module may not include merl.hrl!
+
+-type tree() :: erl_syntax:syntaxTree().
+
+-type tree_or_trees() :: tree() | [tree()].
+
+-type pattern() :: tree() | template().
+
+-type pattern_or_patterns() :: pattern() | [pattern()].
+
+-type env() :: [{Key::id(), pattern_or_patterns()}].
+
+-type id() :: atom() | integer().
+
+%% A list of strings or binaries is assumed to represent individual lines,
+%% while a flat string or binary represents source code containing newlines.
+-type text() :: string() | binary() | [string()] | [binary()].
+
+-type location() :: erl_anno:location().
+
+
+%% ------------------------------------------------------------------------
+%% Compiling and loading code directly to memory
+
+%% @equiv compile(Code, [])
+compile(Code) ->
+ compile(Code, []).
+
+%% @doc Compile a syntax tree or list of syntax trees representing a module
+%% into a binary BEAM object.
+%% @see compile_and_load/2
+%% @see compile/1
+compile(Code, Options) when not is_list(Code)->
+ case type(Code) of
+ form_list -> compile(erl_syntax:form_list_elements(Code));
+ _ -> compile([Code], Options)
+ end;
+compile(Code, Options0) when is_list(Options0) ->
+ Forms = [erl_syntax:revert(F) || F <- Code],
+ Options = [verbose, report_errors, report_warnings, binary | Options0],
+ compile:noenv_forms(Forms, Options).
+
+
+%% @equiv compile_and_load(Code, [])
+compile_and_load(Code) ->
+ compile_and_load(Code, []).
+
+%% @doc Compile a syntax tree or list of syntax trees representing a module
+%% and load the resulting module into memory.
+%% @see compile/2
+%% @see compile_and_load/1
+compile_and_load(Code, Options) ->
+ case compile(Code, Options) of
+ {ok, ModuleName, Binary} ->
+ _ = code:load_binary(ModuleName, "", Binary),
+ {ok, Binary};
+ Other -> Other
+ end.
+
+
+%% ------------------------------------------------------------------------
+%% Utility functions
+
+
+-spec var(atom()) -> tree().
+
+%% @doc Create a variable.
+
+var(Name) ->
+ erl_syntax:variable(Name).
+
+
+-spec term(term()) -> tree().
+
+%% @doc Create a syntax tree for a constant term.
+
+term(Term) ->
+ erl_syntax:abstract(Term).
+
+
+%% @doc Pretty-print a syntax tree or template to the standard output. This
+%% is a utility function for development and debugging.
+
+print(Ts) when is_list(Ts) ->
+ lists:foreach(fun print/1, Ts);
+print(T) ->
+ io:put_chars(erl_prettypr:format(tree(T))),
+ io:nl().
+
+%% @doc Print the structure of a syntax tree or template to the standard
+%% output. This is a utility function for development and debugging.
+
+show(Ts) when is_list(Ts) ->
+ lists:foreach(fun show/1, Ts);
+show(T) ->
+ io:put_chars(pp(tree(T), 0)),
+ io:nl().
+
+pp(T, I) ->
+ [lists:duplicate(I, $\s),
+ limit(lists:flatten([atom_to_list(type(T)), ": ",
+ erl_prettypr:format(erl_syntax_lib:limit(T,3))]),
+ 79-I),
+ $\n,
+ pp_1(lists:filter(fun (X) -> X =/= [] end, subtrees(T)), I+2)
+ ].
+
+pp_1([G], I) ->
+ pp_2(G, I);
+pp_1([G | Gs], I) ->
+ [pp_2(G, I), lists:duplicate(I, $\s), "+\n" | pp_1(Gs, I)];
+pp_1([], _I) ->
+ [].
+
+pp_2(G, I) ->
+ [pp(E, I) || E <- G].
+
+%% limit string to N characters, stay on a single line and compact whitespace
+limit([$\n | Cs], N) -> limit([$\s | Cs], N);
+limit([$\r | Cs], N) -> limit([$\s | Cs], N);
+limit([$\v | Cs], N) -> limit([$\s | Cs], N);
+limit([$\t | Cs], N) -> limit([$\s | Cs], N);
+limit([$\s, $\s | Cs], N) -> limit([$\s | Cs], N);
+limit([C | Cs], N) when C < 32 -> limit(Cs, N);
+limit([C | Cs], N) when N > 3 -> [C | limit(Cs, N-1)];
+limit([_C1, _C2, _C3, _C4 | _Cs], 3) -> "...";
+limit(Cs, 3) -> Cs;
+limit([_C1, _C2, _C3 | _], 2) -> "..";
+limit(Cs, 2) -> Cs;
+limit([_C1, _C2 | _], 1) -> ".";
+limit(Cs, 1) -> Cs;
+limit(_, _) -> [].
+
+%% ------------------------------------------------------------------------
+%% Parsing and instantiating code fragments
+
+
+-spec qquote(Text::text(), Env::env()) -> tree_or_trees().
+
+%% @doc Parse text and substitute meta-variables.
+%%
+%% @equiv qquote(1, Text, Env)
+
+qquote(Text, Env) ->
+ qquote(1, Text, Env).
+
+
+-spec qquote(StartPos::location(), Text::text(), Env::env()) -> tree_or_trees().
+
+%% @doc Parse text and substitute meta-variables. Takes an initial scanner
+%% starting position as first argument.
+%%
+%% The macro `?Q(Text, Env)' expands to `merl:qquote(?LINE, Text, Env)'.
+%%
+%% @see quote/2
+
+qquote(StartPos, Text, Env) ->
+ subst(quote(StartPos, Text), Env).
+
+
+-spec quote(Text::text()) -> tree_or_trees().
+
+%% @doc Parse text.
+%%
+%% @equiv quote(1, Text)
+
+quote(Text) ->
+ quote(1, Text).
+
+
+-spec quote(StartPos::location(), Text::text()) -> tree_or_trees().
+
+%% @doc Parse text. Takes an initial scanner starting position as first
+%% argument.
+%%
+%% The macro `?Q(Text)' expands to `merl:quote(?LINE, Text, Env)'.
+%%
+%% @see quote/1
+
+quote({Line, Col}, Text)
+ when is_integer(Line), is_integer(Col) ->
+ quote_1(Line, Col, Text);
+quote(StartPos, Text) when is_integer(StartPos) ->
+ quote_1(StartPos, undefined, Text).
+
+quote_1(StartLine, StartCol, Text) ->
+ %% be backwards compatible as far as R12, ignoring any starting column
+ StartPos = case erlang:system_info(version) of
+ "5.6" ++ _ -> StartLine;
+ "5.7" ++ _ -> StartLine;
+ "5.8" ++ _ -> StartLine;
+ _ when StartCol =:= undefined -> StartLine;
+ _ -> {StartLine, StartCol}
+ end,
+ FlatText = flatten_text(Text),
+ {ok, Ts, _} = erl_scan:string(FlatText, StartPos),
+ merge_comments(StartLine, erl_comment_scan:string(FlatText), parse_1(Ts)).
+
+parse_1(Ts) ->
+ %% if dot tokens are present, it is assumed that the text represents
+ %% complete forms, not dot-terminated expressions or similar
+ case split_forms(Ts) of
+ {ok, Fs} -> parse_forms(Fs);
+ error ->
+ parse_2(Ts)
+ end.
+
+split_forms(Ts) ->
+ split_forms(Ts, [], []).
+
+split_forms([{dot,_}=T|Ts], Fs, As) ->
+ split_forms(Ts, [lists:reverse(As, [T]) | Fs], []);
+split_forms([T|Ts], Fs, As) ->
+ split_forms(Ts, Fs, [T|As]);
+split_forms([], Fs, []) ->
+ {ok, lists:reverse(Fs)};
+split_forms([], [], _) ->
+ error; % no dot tokens found - not representing form(s)
+split_forms([], _, [T|_]) ->
+ fail("incomplete form after ~p", [T]).
+
+parse_forms([Ts | Tss]) ->
+ case erl_parse:parse_form(Ts) of
+ {ok, Form} -> [Form | parse_forms(Tss)];
+ {error, R} -> parse_error(R)
+ end;
+parse_forms([]) ->
+ [].
+
+parse_2(Ts) ->
+ %% one or more comma-separated expressions?
+ %% (recall that Ts has no dot tokens if we get to this stage)
+ case erl_parse:parse_exprs(Ts ++ [{dot,0}]) of
+ {ok, Exprs} -> Exprs;
+ {error, E} ->
+ parse_3(Ts ++ [{'end',0}, {dot,0}], [E])
+ end.
+
+parse_3(Ts, Es) ->
+ %% try-clause or clauses?
+ case erl_parse:parse_exprs([{'try',0}, {atom,0,true}, {'catch',0} | Ts]) of
+ {ok, [{'try',_,_,_,_,_}=X]} ->
+ %% get the right kind of qualifiers in the clause patterns
+ erl_syntax:try_expr_handlers(X);
+ {error, E} ->
+ parse_4(Ts, [E|Es])
+ end.
+
+parse_4(Ts, Es) ->
+ %% fun-clause or clauses? (`(a)' is also a pattern, but `(a,b)' isn't,
+ %% so fun-clauses must be tried before normal case-clauses
+ case erl_parse:parse_exprs([{'fun',0} | Ts]) of
+ {ok, [{'fun',_,{clauses,Cs}}]} -> Cs;
+ {error, E} ->
+ parse_5(Ts, [E|Es])
+ end.
+
+parse_5(Ts, Es) ->
+ %% case-clause or clauses?
+ case erl_parse:parse_exprs([{'case',0}, {atom,0,true}, {'of',0} | Ts]) of
+ {ok, [{'case',_,_,Cs}]} -> Cs;
+ {error, E} ->
+ %% select the best error to report
+ parse_error(lists:last(lists:sort([E|Es])))
+ end.
+
+-dialyzer({nowarn_function, parse_error/1}). % no local return
+
+parse_error({L, M, R}) when is_atom(M), is_integer(L) ->
+ fail("~w: ~s", [L, M:format_error(R)]);
+parse_error({{L,C}, M, R}) when is_atom(M), is_integer(L), is_integer(C) ->
+ fail("~w:~w: ~s", [L,C,M:format_error(R)]);
+parse_error({_, M, R}) when is_atom(M) ->
+ fail(M:format_error(R));
+parse_error(R) ->
+ fail("unknown parse error: ~p", [R]).
+
+%% ------------------------------------------------------------------------
+%% Templates, substitution and matching
+
+%% Leaves are normal syntax trees, and inner nodes are tuples
+%% {template,Type,Attrs,Groups} where Groups are lists of lists of nodes.
+%% Metavariables are 1-tuples {VarName}, where VarName is an atom or an
+%% integer. {'_'} and {0} work as anonymous variables in matching. Glob
+%% metavariables are tuples {'*',VarName}, and {'*','_'} and {'*',0} are
+%% anonymous globs.
+
+%% Note that although template() :: tree() | ..., it is implied that these
+%% syntax trees are free from metavariables, so pattern() :: tree() |
+%% template() is in fact a wider type than template().
+
+-type template() :: tree()
+ | {id()}
+ | {'*',id()}
+ | {template, atom(), term(), [[template()]]}.
+
+-type template_or_templates() :: template() | [template()].
+
+-spec template(pattern_or_patterns()) -> template_or_templates().
+
+%% @doc Turn a syntax tree or list of trees into a template or templates.
+%% Templates can be instantiated or matched against, and reverted back to
+%% normal syntax trees using {@link tree/1}. If the input is already a
+%% template, it is not modified further.
+%%
+%% @see subst/2
+%% @see match/2
+%% @see tree/1
+
+template(Trees) when is_list(Trees) ->
+ [template_0(T) || T <- Trees];
+template(Tree) ->
+ template_0(Tree).
+
+template_0({template, _, _, _}=Template) -> Template;
+template_0({'*',_}=Template) -> Template;
+template_0({_}=Template) -> Template;
+template_0(Tree) ->
+ case template_1(Tree) of
+ false -> Tree;
+ {Name} when is_list(Name) ->
+ fail("bad metavariable: '~s'", [tl(Name)]); % drop v/n from name
+ Template -> Template
+ end.
+
+%% returns either a template or a lifted metavariable {String}, or 'false'
+%% if Tree contained no metavariables
+template_1(Tree) ->
+ case subtrees(Tree) of
+ [] ->
+ case metavar(Tree) of
+ {"v_"++Cs}=V when Cs =/= [] -> V; % to be lifted
+ {"n0"++Cs}=V when Cs =/= [] -> V; % to be lifted
+ {"v@"++Cs} when Cs =/= [] -> {'*',list_to_atom(Cs)};
+ {"n9"++Cs} when Cs =/= [] -> {'*',list_to_integer(Cs)};
+ {"v"++Cs} -> {list_to_atom(Cs)};
+ {"n"++Cs} -> {list_to_integer(Cs)};
+ false -> false
+ end;
+ Gs ->
+ case template_2(Gs, [], false) of
+ Gs1 when is_list(Gs1) ->
+ {template, type(Tree), erl_syntax:get_attrs(Tree), Gs1};
+ Other ->
+ Other
+ end
+ end.
+
+template_2([G | Gs], As, Bool) ->
+ case template_3(G, [], false) of
+ {"v_"++Cs}=V when Cs =/= [] -> V; % lift further
+ {"n0"++Cs}=V when Cs =/= [] -> V; % lift further
+ {"v@"++Cs} when Cs =/= [] -> {'*',list_to_atom(Cs)}; % stop
+ {"n9"++Cs} when Cs =/= [] -> {'*',list_to_integer(Cs)}; % stop
+ {"v"++Cs} when is_list(Cs) -> {list_to_atom(Cs)}; % stop
+ {"n"++Cs} when is_list(Cs) -> {list_to_integer(Cs)}; % stop
+ false -> template_2(Gs, [G | As], Bool);
+ G1 -> template_2(Gs, [G1 | As], true)
+ end;
+template_2([], _As, false) -> false;
+template_2([], As, true) -> lists:reverse(As).
+
+template_3([T | Ts], As, Bool) ->
+ case template_1(T) of
+ {"v_"++Cs} when Cs =/= [] -> {"v"++Cs}; % lift
+ {"n0"++Cs} when Cs =/= [] -> {"n"++Cs}; % lift
+ false -> template_3(Ts, [T | As], Bool);
+ T1 -> template_3(Ts, [T1 | As], true)
+ end;
+template_3([], _As, false) -> false;
+template_3([], As, true) -> lists:reverse(As).
+
+
+%% @doc Turn a template into a syntax tree representing the template.
+%% Meta-variables in the template are turned into normal Erlang variables if
+%% their names (after the metavariable prefix characters) begin with an
+%% uppercase character. E.g., `_@Foo' in the template becomes the variable
+%% `Foo' in the meta-template. Furthermore, variables ending with `@' are
+%% automatically wrapped in a call to merl:term/1, so e.g. `_@Foo@ in the
+%% template becomes `merl:term(Foo)' in the meta-template.
+
+-spec meta_template(template_or_templates()) -> tree_or_trees().
+
+meta_template(Templates) when is_list(Templates) ->
+ [meta_template_1(T) || T <- Templates];
+meta_template(Template) ->
+ meta_template_1(Template).
+
+meta_template_1({template, Type, Attrs, Groups}) ->
+ erl_syntax:tuple(
+ [erl_syntax:atom(template),
+ erl_syntax:atom(Type),
+ erl_syntax:abstract(Attrs),
+ erl_syntax:list([erl_syntax:list([meta_template_1(T) || T <- G])
+ || G <- Groups])]);
+meta_template_1({Var}=V) ->
+ meta_template_2(Var, V);
+meta_template_1({'*',Var}=V) ->
+ meta_template_2(Var, V);
+meta_template_1(Leaf) ->
+ erl_syntax:abstract(Leaf).
+
+meta_template_2(Var, V) when is_atom(Var) ->
+ case atom_to_list(Var) of
+ [C|_]=Name when C >= $A, C =< $Z ; C >= $À, C =< $Þ, C /= $× ->
+ case lists:reverse(Name) of
+ "@"++([_|_]=RevRealName) -> % don't allow empty RealName
+ RealName = lists:reverse(RevRealName),
+ erl_syntax:application(erl_syntax:atom(merl),
+ erl_syntax:atom(term),
+ [erl_syntax:variable(RealName)]);
+ _ ->
+ %% plain automatic metavariable
+ erl_syntax:variable(Name)
+ end;
+ _ ->
+ erl_syntax:abstract(V)
+ end;
+meta_template_2(Var, V) when is_integer(Var) ->
+ if Var > 9, (Var rem 10) =:= 9 ->
+ %% at least 2 digits, ends in 9: make it a Q-variable
+ if Var > 99, (Var rem 100) =:= 99 ->
+ %% at least 3 digits, ends in 99: wrap in merl:term/1
+ Name = "Q" ++ integer_to_list(Var div 100),
+ erl_syntax:application(erl_syntax:atom(merl),
+ erl_syntax:atom(term),
+ [erl_syntax:variable(Name)]);
+ true ->
+ %% plain automatic Q-variable
+ Name = integer_to_list(Var div 10),
+ erl_syntax:variable("Q" ++ Name)
+ end;
+ true ->
+ erl_syntax:abstract(V)
+ end.
+
+
+
+-spec template_vars(template_or_templates()) -> [id()].
+
+%% @doc Return an ordered list of the metavariables in the template.
+
+template_vars(Template) ->
+ template_vars(Template, []).
+
+template_vars(Templates, Vars) when is_list(Templates) ->
+ lists:foldl(fun template_vars_1/2, Vars, Templates);
+template_vars(Template, Vars) ->
+ template_vars_1(Template, Vars).
+
+template_vars_1({template, _, _, Groups}, Vars) ->
+ lists:foldl(fun (G, V) -> lists:foldl(fun template_vars_1/2, V, G) end,
+ Vars, Groups);
+template_vars_1({Var}, Vars) ->
+ ordsets:add_element(Var, Vars);
+template_vars_1({'*',Var}, Vars) ->
+ ordsets:add_element(Var, Vars);
+template_vars_1(_, Vars) ->
+ Vars.
+
+
+-spec tree(template_or_templates()) -> tree_or_trees().
+
+%% @doc Revert a template to a normal syntax tree. Any remaining
+%% metavariables are turned into `@'-prefixed atoms or `909'-prefixed
+%% integers.
+%% @see template/1
+
+tree(Templates) when is_list(Templates) ->
+ [tree_1(T) || T <- Templates];
+tree(Template) ->
+ tree_1(Template).
+
+tree_1({template, Type, Attrs, Groups}) ->
+ %% flattening here is needed for templates created via source transforms
+ Gs = [lists:flatten([tree_1(T) || T <- G]) || G <- Groups],
+ erl_syntax:set_attrs(make_tree(Type, Gs), Attrs);
+tree_1({Var}) when is_atom(Var) ->
+ erl_syntax:atom(list_to_atom("@"++atom_to_list(Var)));
+tree_1({Var}) when is_integer(Var) ->
+ erl_syntax:integer(list_to_integer("909"++integer_to_list(Var)));
+tree_1({'*',Var}) when is_atom(Var) ->
+ erl_syntax:atom(list_to_atom("@@"++atom_to_list(Var)));
+tree_1({'*',Var}) when is_integer(Var) ->
+ erl_syntax:integer(list_to_integer("9099"++integer_to_list(Var)));
+tree_1(Leaf) ->
+ Leaf. % any syntax tree, not necessarily atomic (due to substitutions)
+
+
+-spec subst(pattern_or_patterns(), env()) -> tree_or_trees().
+
+%% @doc Substitute metavariables in a pattern or list of patterns, yielding
+%% a syntax tree or list of trees as result. Both for normal metavariables
+%% and glob metavariables, the substituted value may be a single element or
+%% a list of elements. For example, if a list representing `1, 2, 3' is
+%% substituted for `var' in either of `[foo, _@var, bar]' or `[foo, _@@var,
+%% bar]', the result represents `[foo, 1, 2, 3, bar]'.
+
+subst(Trees, Env) when is_list(Trees) ->
+ [subst_0(T, Env) || T <- Trees];
+subst(Tree, Env) ->
+ subst_0(Tree, Env).
+
+subst_0(Tree, Env) ->
+ tree_1(subst_1(template(Tree), Env)).
+
+
+-spec tsubst(pattern_or_patterns(), env()) -> template_or_templates().
+
+%% @doc Like subst/2, but does not convert the result from a template back
+%% to a tree. Useful if you want to do multiple separate substitutions.
+%% @see subst/2
+%% @see tree/1
+
+tsubst(Trees, Env) when is_list(Trees) ->
+ [subst_1(template(T), Env) || T <- Trees];
+tsubst(Tree, Env) ->
+ subst_1(template(Tree), Env).
+
+subst_1({template, Type, Attrs, Groups}, Env) ->
+ Gs1 = [lists:flatten([subst_1(T, Env) || T <- G]) || G <- Groups],
+ {template, Type, Attrs, Gs1};
+subst_1({Var}=V, Env) ->
+ case lists:keyfind(Var, 1, Env) of
+ {Var, TreeOrTrees} -> TreeOrTrees;
+ false -> V
+ end;
+subst_1({'*',Var}=V, Env) ->
+ case lists:keyfind(Var, 1, Env) of
+ {Var, TreeOrTrees} -> TreeOrTrees;
+ false -> V
+ end;
+subst_1(Leaf, _Env) ->
+ Leaf.
+
+
+-spec alpha(pattern_or_patterns(), [{id(), id()}]) -> template_or_templates().
+
+%% @doc Alpha converts a pattern (renames variables). Similar to tsubst/1,
+%% but only renames variables (including globs).
+%% @see tsubst/2
+
+alpha(Trees, Env) when is_list(Trees) ->
+ [alpha_1(template(T), Env) || T <- Trees];
+alpha(Tree, Env) ->
+ alpha_1(template(Tree), Env).
+
+alpha_1({template, Type, Attrs, Groups}, Env) ->
+ Gs1 = [lists:flatten([alpha_1(T, Env) || T <- G]) || G <- Groups],
+ {template, Type, Attrs, Gs1};
+alpha_1({Var}=V, Env) ->
+ case lists:keyfind(Var, 1, Env) of
+ {Var, NewVar} -> {NewVar};
+ false -> V
+ end;
+alpha_1({'*',Var}=V, Env) ->
+ case lists:keyfind(Var, 1, Env) of
+ {Var, NewVar} -> {'*',NewVar};
+ false -> V
+ end;
+alpha_1(Leaf, _Env) ->
+ Leaf.
+
+
+-spec match(pattern_or_patterns(), tree_or_trees()) ->
+ {ok, env()} | error.
+
+%% @doc Match a pattern against a syntax tree (or patterns against syntax
+%% trees) returning an environment mapping variable names to subtrees; the
+%% environment is always sorted on keys. Note that multiple occurrences of
+%% metavariables in the pattern is not allowed, but is not checked.
+%%
+%% @see template/1
+%% @see switch/2
+
+match(Patterns, Trees) when is_list(Patterns), is_list(Trees) ->
+ try {ok, match_1(Patterns, Trees, [])}
+ catch
+ error -> error
+ end;
+match(Patterns, Tree) when is_list(Patterns) -> match(Patterns, [Tree]);
+match(Pattern, Trees) when is_list(Trees) -> match([Pattern], Trees);
+match(Pattern, Tree) ->
+ try {ok, match_template(template(Pattern), Tree, [])}
+ catch
+ error -> error
+ end.
+
+match_1([P|Ps], [T | Ts], Dict) ->
+ match_1(Ps, Ts, match_template(template(P), T, Dict));
+match_1([], [], Dict) ->
+ Dict;
+match_1(_, _, _Dict) ->
+ erlang:error(merl_match_arity).
+
+%% match a template against a syntax tree
+match_template({template, Type, _, Gs}, Tree, Dict) ->
+ case type(Tree) of
+ Type -> match_template_1(Gs, subtrees(Tree), Dict);
+ _ -> throw(error) % type mismatch
+ end;
+match_template({Var}, _Tree, Dict)
+ when Var =:= '_' ; Var =:= 0 ->
+ Dict; % anonymous variable
+match_template({Var}, Tree, Dict) ->
+ orddict:store(Var, Tree, Dict);
+match_template(Tree1, Tree2, Dict) ->
+ %% if Tree1 is not a template, Tree1 and Tree2 are both syntax trees
+ case compare_trees(Tree1, Tree2) of
+ true -> Dict;
+ false -> throw(error) % different trees
+ end.
+
+match_template_1([G1 | Gs1], [G2 | Gs2], Dict) ->
+ match_template_2(G1, G2, match_template_1(Gs1, Gs2, Dict));
+match_template_1([], [], Dict) ->
+ Dict;
+match_template_1(_, _, _Dict) ->
+ throw(error). % shape mismatch
+
+match_template_2([{Var} | Ts1], [_ | Ts2], Dict)
+ when Var =:= '_' ; Var =:= 0 ->
+ match_template_2(Ts1, Ts2, Dict); % anonymous variable
+match_template_2([{Var} | Ts1], [Tree | Ts2], Dict) ->
+ match_template_2(Ts1, Ts2, orddict:store(Var, Tree, Dict));
+match_template_2([{'*',Var} | Ts1], Ts2, Dict) ->
+ match_glob(lists:reverse(Ts1), lists:reverse(Ts2), Var, Dict);
+match_template_2([T1 | Ts1], [T2 | Ts2], Dict) ->
+ match_template_2(Ts1, Ts2, match_template(T1, T2, Dict));
+match_template_2([], [], Dict) ->
+ Dict;
+match_template_2(_, _, _Dict) ->
+ throw(error). % shape mismatch
+
+%% match the tails in reverse order; no further globs allowed
+match_glob([{'*',Var} | _], _, _, _) ->
+ fail("multiple glob variables in same match group: ~w", [Var]);
+match_glob([T1 | Ts1], [T2 | Ts2], Var, Dict) ->
+ match_glob(Ts1, Ts2, Var, match_template(T1, T2, Dict));
+match_glob([], _Group, Var, Dict) when Var =:= '_' ; Var =:= 0 ->
+ Dict; % anonymous glob variable
+match_glob([], Group, Var, Dict) ->
+ orddict:store(Var, lists:reverse(Group), Dict);
+match_glob(_, _, _, _Dict) ->
+ throw(error). % shape mismatch
+
+
+%% compare two syntax trees for equivalence
+compare_trees(T1, T2) ->
+ Type1 = type(T1),
+ case type(T2) of
+ Type1 ->
+ case subtrees(T1) of
+ [] ->
+ case subtrees(T2) of
+ [] -> compare_leaves(Type1, T1, T2);
+ _Gs2 -> false % shape mismatch
+ end;
+ Gs1 ->
+ case subtrees(T2) of
+ [] -> false; % shape mismatch
+ Gs2 -> compare_trees_1(Gs1, Gs2)
+ end
+ end;
+ _Type2 ->
+ false % different tree types
+ end.
+
+compare_trees_1([G1 | Gs1], [G2 | Gs2]) ->
+ compare_trees_2(G1, G2) andalso compare_trees_1(Gs1, Gs2);
+compare_trees_1([], []) ->
+ true;
+compare_trees_1(_, _) ->
+ false. % shape mismatch
+
+compare_trees_2([T1 | Ts1], [T2 | Ts2]) ->
+ compare_trees(T1, T2) andalso compare_trees_2(Ts1, Ts2);
+compare_trees_2([], []) ->
+ true;
+compare_trees_2(_, _) ->
+ false. % shape mismatch
+
+compare_leaves(Type, T1, T2) ->
+ case Type of
+ atom ->
+ erl_syntax:atom_value(T1)
+ =:= erl_syntax:atom_value(T2);
+ char ->
+ erl_syntax:char_value(T1)
+ =:= erl_syntax:char_value(T2);
+ float ->
+ erl_syntax:float_value(T1)
+ =:= erl_syntax:float_value(T2);
+ integer ->
+ erl_syntax:integer_value(T1)
+ =:= erl_syntax:integer_value(T2);
+ string ->
+ erl_syntax:string_value(T1)
+ =:= erl_syntax:string_value(T2);
+ operator ->
+ erl_syntax:operator_name(T1)
+ =:= erl_syntax:operator_name(T2);
+ text ->
+ erl_syntax:text_string(T1)
+ =:= erl_syntax:text_string(T2);
+ variable ->
+ erl_syntax:variable_name(T1)
+ =:= erl_syntax:variable_name(T2);
+ _ ->
+ true % trivially equal nodes
+ end.
+
+
+%% @doc Match against one or more clauses with patterns and optional guards.
+%%
+%% Note that clauses following a default action will be ignored.
+%%
+%% @see match/2
+
+-type switch_clause() ::
+ {pattern_or_patterns(), guarded_actions()}
+ | {pattern_or_patterns(), guard_test(), switch_action()}
+ | default_action().
+
+-type guarded_actions() :: guarded_action() | [guarded_action()].
+
+-type guarded_action() :: switch_action() | {guard_test(), switch_action()}.
+
+-type switch_action() :: fun( (env()) -> any() ).
+
+-type guard_test() :: fun( (env()) -> boolean() ).
+
+-type default_action() :: fun( () -> any() ).
+
+
+-spec switch(tree_or_trees(), [switch_clause()]) -> any().
+
+switch(Trees, [{Patterns, GuardedActions} | Cs]) when is_list(GuardedActions) ->
+ switch_1(Trees, Patterns, GuardedActions, Cs);
+switch(Trees, [{Patterns, GuardedAction} | Cs]) ->
+ switch_1(Trees, Patterns, [GuardedAction], Cs);
+switch(Trees, [{Patterns, Guard, Action} | Cs]) ->
+ switch_1(Trees, Patterns, [{Guard, Action}], Cs);
+switch(_Trees, [Default | _Cs]) when is_function(Default, 0) ->
+ Default();
+switch(_Trees, []) ->
+ erlang:error(merl_switch_clause);
+switch(_Tree, _) ->
+ erlang:error(merl_switch_badarg).
+
+switch_1(Trees, Patterns, GuardedActions, Cs) ->
+ case match(Patterns, Trees) of
+ {ok, Env} ->
+ switch_2(Env, GuardedActions, Trees, Cs);
+ error ->
+ switch(Trees, Cs)
+ end.
+
+switch_2(Env, [{Guard, Action} | Bs], Trees, Cs)
+ when is_function(Guard, 1), is_function(Action, 1) ->
+ case Guard(Env) of
+ true -> Action(Env);
+ false -> switch_2(Env, Bs, Trees, Cs)
+ end;
+switch_2(Env, [Action | _Bs], _Trees, _Cs) when is_function(Action, 1) ->
+ Action(Env);
+switch_2(_Env, [], Trees, Cs) ->
+ switch(Trees, Cs);
+switch_2(_Env, _, _Trees, _Cs) ->
+ erlang:error(merl_switch_badarg).
+
+
+%% ------------------------------------------------------------------------
+%% Internal utility functions
+
+-dialyzer({nowarn_function, fail/1}). % no local return
+
+fail(Text) ->
+ fail(Text, []).
+
+fail(Fs, As) ->
+ throw({error, lists:flatten(io_lib:format(Fs, As))}).
+
+flatten_text([L | _]=Lines) when is_list(L) ->
+ lists:foldr(fun(S, T) -> S ++ [$\n | T] end, "", Lines);
+flatten_text([B | _]=Lines) when is_binary(B) ->
+ lists:foldr(fun(S, T) -> binary_to_list(S) ++ [$\n | T] end, "", Lines);
+flatten_text(Text) when is_binary(Text) ->
+ binary_to_list(Text);
+flatten_text(Text) ->
+ Text.
+
+-spec metavar(tree()) -> {string()} | false.
+
+%% Check if a syntax tree represents a metavariable. If not, 'false' is
+%% returned; otherwise, this returns a 1-tuple with a string containing the
+%% variable name including lift/glob prefixes but without any leading
+%% metavariable prefix, and instead prefixed with "v" for a variable or "i"
+%% for an integer.
+%%
+%% Metavariables are atoms starting with @, variables starting with _@,
+%% strings starting with "'@, or integers starting with 909. Following the
+%% prefix, one or more _ or 0 characters (unless it's the last character in
+%% the name) may be used to indicate "lifting" of the variable one or more
+%% levels , and after that, a @ or 9 character indicates a glob metavariable
+%% rather than a normal metavariable. If the name after the prefix is _ or
+%% 0, the variable is treated as an anonymous catch-all pattern in matches.
+
+metavar(Tree) ->
+ case type(Tree) of
+ atom ->
+ case erl_syntax:atom_name(Tree) of
+ "@" ++ Cs when Cs =/= [] -> {"v"++Cs};
+ _ -> false
+ end;
+ variable ->
+ case erl_syntax:variable_literal(Tree) of
+ "_@" ++ Cs when Cs =/= [] -> {"v"++Cs};
+ _ -> false
+ end;
+ integer ->
+ case erl_syntax:integer_value(Tree) of
+ N when N >= 9090 ->
+ case integer_to_list(N) of
+ "909" ++ Cs -> {"n"++Cs};
+ _ -> false
+ end;
+ _ -> false
+ end;
+ string ->
+ case erl_syntax:string_value(Tree) of
+ "'@" ++ Cs -> {"v"++Cs};
+ _ -> false
+ end;
+ _ ->
+ false
+ end.
+
+%% wrappers around erl_syntax functions to provide more uniform shape of
+%% generic subtrees (maybe this can be fixed in syntax_tools one day)
+
+type(T) ->
+ case erl_syntax:type(T) of
+ nil -> list;
+ Type -> Type
+ end.
+
+subtrees(T) ->
+ case erl_syntax:type(T) of
+ tuple ->
+ [erl_syntax:tuple_elements(T)]; %% don't treat {} as a leaf
+ nil ->
+ [[], []]; %% don't treat [] as a leaf, but as a list
+ list ->
+ case erl_syntax:list_suffix(T) of
+ none ->
+ [erl_syntax:list_prefix(T), []];
+ S ->
+ [erl_syntax:list_prefix(T), [S]]
+ end;
+ binary_field ->
+ [[erl_syntax:binary_field_body(T)],
+ erl_syntax:binary_field_types(T)];
+ clause ->
+ case erl_syntax:clause_guard(T) of
+ none ->
+ [erl_syntax:clause_patterns(T), [],
+ erl_syntax:clause_body(T)];
+ G ->
+ [erl_syntax:clause_patterns(T), [G],
+ erl_syntax:clause_body(T)]
+ end;
+ receive_expr ->
+ case erl_syntax:receive_expr_timeout(T) of
+ none ->
+ [erl_syntax:receive_expr_clauses(T), [], []];
+ E ->
+ [erl_syntax:receive_expr_clauses(T), [E],
+ erl_syntax:receive_expr_action(T)]
+ end;
+ record_expr ->
+ case erl_syntax:record_expr_argument(T) of
+ none ->
+ [[], [erl_syntax:record_expr_type(T)],
+ erl_syntax:record_expr_fields(T)];
+ V ->
+ [[V], [erl_syntax:record_expr_type(T)],
+ erl_syntax:record_expr_fields(T)]
+ end;
+ record_field ->
+ case erl_syntax:record_field_value(T) of
+ none ->
+ [[erl_syntax:record_field_name(T)], []];
+ V ->
+ [[erl_syntax:record_field_name(T)], [V]]
+ end;
+ _ ->
+ erl_syntax:subtrees(T)
+ end.
+
+make_tree(list, [P, []]) -> erl_syntax:list(P);
+make_tree(list, [P, [S]]) -> erl_syntax:list(P, S);
+make_tree(tuple, [E]) -> erl_syntax:tuple(E);
+make_tree(binary_field, [[B], Ts]) -> erl_syntax:binary_field(B, Ts);
+make_tree(clause, [P, [], B]) -> erl_syntax:clause(P, none, B);
+make_tree(clause, [P, [G], B]) -> erl_syntax:clause(P, G, B);
+make_tree(receive_expr, [C, [], _A]) -> erl_syntax:receive_expr(C);
+make_tree(receive_expr, [C, [E], A]) -> erl_syntax:receive_expr(C, E, A);
+make_tree(record_expr, [[], [T], F]) -> erl_syntax:record_expr(T, F);
+make_tree(record_expr, [[E], [T], F]) -> erl_syntax:record_expr(E, T, F);
+make_tree(record_field, [[N], []]) -> erl_syntax:record_field(N);
+make_tree(record_field, [[N], [E]]) -> erl_syntax:record_field(N, E);
+make_tree(Type, Groups) ->
+ erl_syntax:make_tree(Type, Groups).
+
+merge_comments(_StartLine, [], [T]) -> T;
+merge_comments(_StartLine, [], Ts) -> Ts;
+merge_comments(StartLine, Comments, Ts) ->
+ merge_comments(StartLine, Comments, Ts, []).
+
+merge_comments(_StartLine, [], [], [T]) -> T;
+merge_comments(_StartLine, [], [T], []) -> T;
+merge_comments(_StartLine, [], Ts, Acc) ->
+ lists:reverse(Acc, Ts);
+merge_comments(StartLine, Cs, [], Acc) ->
+ merge_comments(StartLine, [], [],
+ [erl_syntax:set_pos(
+ erl_syntax:comment(Indent, Text),
+ StartLine + Line - 1)
+ || {Line, _, Indent, Text} <- Cs] ++ Acc);
+merge_comments(StartLine, [C|Cs], [T|Ts], Acc) ->
+ {Line, _Col, Indent, Text} = C,
+ CommentLine = StartLine + Line - 1,
+ case erl_syntax:get_pos(T) of
+ Pos when Pos < CommentLine ->
+ %% TODO: traverse sub-tree rather than only the top level nodes
+ merge_comments(StartLine, [C|Cs], Ts, [T|Acc]);
+ CommentLine ->
+ Tc = erl_syntax:add_postcomments(
+ [erl_syntax:comment(Indent, Text)], T),
+ merge_comments(StartLine, Cs, [Tc|Ts], Acc);
+ _ ->
+ Tc = erl_syntax:add_precomments(
+ [erl_syntax:comment(Indent, Text)], T),
+ merge_comments(StartLine, Cs, [Tc|Ts], Acc)
+ end.
diff --git a/lib/syntax_tools/src/merl_tests.erl b/lib/syntax_tools/src/merl_tests.erl
new file mode 100644
index 0000000000..c1aae3100e
--- /dev/null
+++ b/lib/syntax_tools/src/merl_tests.erl
@@ -0,0 +1,539 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012-2015 Richard Carlsson
+%% @doc Unit tests for merl.
+%% @private
+
+-module(merl_tests).
+
+%-define(MERL_NO_TRANSFORM, true).
+-include("merl.hrl").
+
+-include_lib("eunit/include/eunit.hrl").
+
+
+%% utilities
+
+f(Ts) when is_list(Ts) ->
+ lists:flatmap(fun erl_prettypr:format/1, Ts);
+f(T) ->
+ erl_prettypr:format(T).
+
+fe(Env) -> [{Key, f(T)} || {Key, T} <- Env].
+
+g_exported_() ->
+ %% for testing the parse transform, autoexported to avoid complaints
+ {ok, merl:quote(?LINE, "42")}.
+
+
+ok({ok, X}) -> X.
+
+
+%%
+%% tests
+%%
+
+parse_error_test_() ->
+ [?_assertThrow({error, "1: syntax error before: '{'" ++ _},
+ f(merl:quote("{")))
+ ].
+
+term_test_() ->
+ [?_assertEqual(tuple, erl_syntax:type(merl:term({}))),
+ ?_assertEqual("{foo, 42}", f(merl:term({foo, 42})))
+ ].
+
+quote_form_test_() ->
+ [?_assertEqual("f(X) -> {ok, X}.",
+ f(?Q("f(X) -> {ok, X}."))),
+ ?_assertEqual("-module(foo).",
+ f(?Q("-module(foo)."))),
+ ?_assertEqual("-import(bar, [f/1, g/2]).",
+ f(?Q("-import(bar, [f/1, g/2])."))),
+ ?_assertEqual(("-module(foo)."
+ "-export([f/1])."
+ "f(X) -> {ok, X}."),
+ f(?Q(["-module(foo).",
+ "-export([f/1]).",
+ "f(X) -> {ok, X}."])))
+ ].
+
+quote_term_test_() ->
+ [?_assertEqual("foo",
+ f(?Q("foo"))),
+ ?_assertEqual("42",
+ f(?Q("42"))),
+ ?_assertEqual("{foo, 42}",
+ f(?Q("{foo, 42}"))),
+ ?_assertEqual(("1" ++ "2" ++ "3"),
+ f(?Q("1, 2, 3"))),
+ ?_assertEqual(("foo" "42" "{}" "true"),
+ f(?Q("foo, 42, {}, (true)")))
+ ].
+
+quote_expr_test_() ->
+ [?_assertEqual("2 + 2",
+ f(?Q("2 + 2"))),
+ ?_assertEqual("f(foo, 42)",
+ f(?Q("f(foo, 42)"))),
+ ?_assertEqual("case X of\n a -> 1;\n b -> 2\nend",
+ f(?Q("case X of a -> 1; b -> 2 end"))),
+ ?_assertEqual(("2 + 2" ++ "f(42)" ++ "catch 22"),
+ f(?Q("2 + 2, f(42), catch 22")))
+ ].
+
+quote_try_clause_test_() ->
+ [?_assertEqual("(error:R) when R =/= foo -> ok",
+ f(?Q("error:R when R =/= foo -> ok"))),
+ %% note that without any context, clauses are printed as fun-clauses
+ ?_assertEqual(("(error:badarg) -> badarg"
+ "(exit:normal) -> normal"
+ "(_) -> other"),
+ f(?Q(["error:badarg -> badarg;",
+ "exit:normal -> normal;"
+ "_ -> other"])))
+ ].
+
+quote_fun_clause_test_() ->
+ [?_assertEqual("(X, Y) when X < Y -> {ok, X}",
+ f(?Q("(X, Y) when X < Y -> {ok, X}"))),
+ ?_assertEqual(("(X, Y) when X < Y -> less"
+ "(X, Y) when X > Y -> greater"
+ "(_, _) -> equal"),
+ f(?Q(["(X, Y) when X < Y -> less;",
+ "(X, Y) when X > Y -> greater;"
+ "(_, _) -> equal"])))].
+
+quote_case_clause_test_() ->
+ [?_assertEqual("({X, Y}) when X < Y -> X",
+ f(?Q("{X, Y} when X < Y -> X"))),
+ ?_assertEqual(("({X, Y}) when X < Y -> -1"
+ "({X, Y}) when X > Y -> 1"
+ "(_) -> 0"),
+ f(?Q(["{X, Y} when X < Y -> -1;",
+ "{X, Y} when X > Y -> 1;"
+ "_ -> 0"])))].
+
+quote_comment_test_() ->
+ [?_assertEqual("%% comment preserved\n"
+ "{foo, 42}",
+ f(?Q(["%% comment preserved",
+ "{foo, 42}"]))),
+ ?_assertEqual("{foo, 42}"
+ "%% comment preserved\n",
+ f(?Q(["{foo, 42}",
+ "%% comment preserved"]))),
+ ?_assertEqual(" % just a comment (with indent)\n",
+ f(?Q(" % just a comment (with indent)")))
+ ].
+
+metavar_test_() ->
+ [?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("'@foo'"))))),
+ ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("_@foo"))))),
+ ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("\"'@foo\""))))),
+ ?_assertEqual("{'@foo'}", f(merl:tree(merl:template(?Q("{_@foo}"))))),
+ ?_assertEqual("'@foo'", f(merl:tree(merl:template(?Q("{_@_foo}"))))),
+ ?_assertEqual("909123", f(merl:tree(merl:template(?Q("{9090123}"))))),
+ ?_assertEqual("{'@foo'}",
+ f(merl:tree(merl:template(?Q("{{{_@__foo}}}"))))),
+ ?_assertEqual("{909123}",
+ f(merl:tree(merl:template(?Q("{{{90900123}}}"))))),
+ ?_assertEqual("{'@@foo'}",
+ f(merl:tree(merl:template(?Q("{{{_@__@foo}}}"))))),
+ ?_assertEqual("{9099123}",
+ f(merl:tree(merl:template(?Q("{{{909009123}}}")))))
+ ].
+
+subst_test_() ->
+ [?_assertEqual("42",
+ f(merl:subst(?Q("_@foo"), [{foo, merl:term(42)}]))),
+ ?_assertEqual("'@foo'",
+ f(merl:subst(?Q("_@foo"), []))),
+ ?_assertEqual("{42}",
+ f(merl:subst(?Q("{_@foo}"),
+ [{foo, merl:term(42)}]))),
+ ?_assertEqual("{'@foo'}",
+ f(merl:subst(?Q("{_@foo}"), []))),
+ ?_assertEqual("fun bar/0",
+ f(merl:subst(merl:template(?Q("fun '@foo'/0")),
+ [{foo, merl:term(bar)}]))),
+ ?_assertEqual("fun foo/3",
+ f(merl:subst(merl:template(?Q("fun foo/9091")),
+ [{1, merl:term(3)}]))),
+ ?_assertEqual("[42]",
+ f(merl:subst(merl:template(?Q("[_@foo]")),
+ [{foo, merl:term(42)}]))),
+ ?_assertEqual("[foo, bar]",
+ f(merl:subst(merl:template(?Q("[_@foo]")),
+ [{foo, [merl:term(foo),merl:term(bar)]}]))),
+ ?_assertEqual("{fee, fie, foe, fum}",
+ f(merl:subst(merl:template(?Q("{fee, _@foo, fum}")),
+ [{foo, [merl:term(fie),merl:term(foe)]}]))),
+ ?_assertEqual("[foo, bar]",
+ f(merl:subst(merl:template(?Q("[_@@foo]")),
+ [{foo, [merl:term(foo),merl:term(bar)]}]))),
+ ?_assertEqual("{fee, fie, foe, fum}",
+ f(merl:subst(merl:template(?Q("{fee, _@@foo, fum}")),
+ [{foo, [merl:term(fie),merl:term(foe)]}]))),
+ ?_assertEqual("['@@foo']",
+ f(merl:subst(merl:template(?Q("[_@@foo]")), []))),
+ ?_assertEqual("foo",
+ f(merl:subst(merl:template(?Q("[_@_foo]")),
+ [{foo, merl:term(foo)}]))),
+ ?_assertEqual("{'@foo'}",
+ f(merl:subst(merl:template(?Q("{[_@_foo]}")), []))),
+ ?_assertEqual("{'@@foo'}",
+ f(merl:subst(merl:template(?Q("{[_@_@foo]}")), []))),
+ ?_assertEqual("-export([foo/1, bar/2]).",
+ f(merl:subst(merl:template(?Q("-export(['@_@foo'/0]).")),
+ [{foo, [erl_syntax:arity_qualifier(
+ merl:term(foo),
+ merl:term(1)),
+ erl_syntax:arity_qualifier(
+ merl:term(bar),
+ merl:term(2))
+ ]}
+ ])))
+ ].
+
+match_test_() ->
+ [?_assertEqual({ok, []}, merl:match(?Q("foo"), ?Q("foo"))),
+ ?_assertEqual(error, merl:match(?Q("foo"), ?Q("bar"))),
+ ?_assertEqual({ok,[]}, merl:match(?Q("{foo,42}"), ?Q("{foo,42}"))),
+ ?_assertEqual(error, merl:match(?Q("{foo,42}"), ?Q("{foo,bar}"))),
+ ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[42]]"), ?Q("[foo,[42]]"))),
+ ?_assertEqual(error, merl:match(?Q("[foo,[42]]"), ?Q("[foo,{42}]"))),
+ ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[_@_]]"),
+ ?Q("[foo,[42]]"))),
+ ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[9090]]"),
+ ?Q("[foo,[42]]"))),
+ ?_assertEqual({ok,[]}, merl:match(?Q("{_@_,[_@_,2]}"),
+ ?Q("{foo,[1,2]}"))),
+ ?_assertEqual(error, merl:match(?Q("{_@_,[_@_,2]}"),
+ ?Q("{foo,[1,3]}"))),
+ ?_assertEqual({ok,[]}, merl:match(?Q("[foo,[9090,9090]]"),
+ ?Q("[foo,[1,2]]"))),
+ ?_assertEqual(error, merl:match(?Q("[foo,[9090,9090]]"),
+ ?Q("[foo,[1,2,3]]"))),
+ ?_assertEqual([{foo,"42"}],
+ fe(ok(merl:match(?Q("_@foo"), ?Q("42"))))),
+ ?_assertEqual([{foo,"42"}],
+ fe(ok(merl:match(?Q("{_@foo}"), ?Q("{42}"))))),
+ ?_assertEqual([{1,"0"},{foo,"bar"}],
+ fe(ok(merl:match(?Q("fun '@foo'/9091"),
+ ?Q("fun bar/0"))))),
+ ?_assertEqual([{line,"17"},{text,"\"hello\""}],
+ fe(ok(merl:match(?Q("{_@line, _@text}"),
+ ?Q("{17, \"hello\"}"))))),
+ ?_assertEqual([{line,"17"},{text,"\"hello\""}],
+ fe(ok(merl:match(?Q("foo(_@line, _@text)"),
+ ?Q("foo(17, \"hello\")"))))),
+ ?_assertEqual([{foo,""}],
+ fe(ok(merl:match(?Q("f(_@@foo)"),
+ ?Q("f()"))))),
+ ?_assertEqual([{foo,"fee"}],
+ fe(ok(merl:match(?Q("f(_@@foo)"),
+ ?Q("f(fee)"))))),
+ ?_assertEqual([{foo,"feefiefum"}],
+ fe(ok(merl:match(?Q("f(_@@foo)"),
+ ?Q("f(fee, fie, fum)"))))),
+ ?_assertEqual([{foo,""}],
+ fe(ok(merl:match(?Q("[_@@foo]"),
+ ?Q("[]"))))),
+ ?_assertEqual([{foo,"fee"}],
+ fe(ok(merl:match(?Q("[_@@foo]"),
+ ?Q("[fee]"))))),
+ ?_assertEqual([{foo,"feefiefoefum"}],
+ fe(ok(merl:match(?Q("[_@@foo]"),
+ ?Q("[fee, fie, foe, fum]"))))),
+ ?_assertEqual([{foo,""}],
+ fe(ok(merl:match(?Q("{_@@foo}"),
+ ?Q("{}"))))),
+ ?_assertEqual([{foo,"fee"}],
+ fe(ok(merl:match(?Q("{_@@foo}"),
+ ?Q("{fee}"))))),
+ ?_assertEqual([{foo,"feefiefoefum"}],
+ fe(ok(merl:match(?Q("{_@@foo}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertEqual([{foo,"fie"}],
+ fe(ok(merl:match(?Q("{fee, _@@foo}"),
+ ?Q("{fee, fie}"))))),
+ ?_assertEqual([{foo,"fiefoefum"}],
+ fe(ok(merl:match(?Q("{fee, _@@foo}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertEqual([{foo,"fie"}],
+ fe(ok(merl:match(?Q("{_@@foo, foe, fum}"),
+ ?Q("{fie, foe, fum}"))))),
+ ?_assertEqual([{foo,"feefie"}],
+ fe(ok(merl:match(?Q("{_@@foo, foe, fum}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertEqual([{foo,"fie"}],
+ fe(ok(merl:match(?Q("{fee, _@@foo, fum}"),
+ ?Q("{fee, fie, fum}"))))),
+ ?_assertEqual([{foo,"fiefoe"}],
+ fe(ok(merl:match(?Q("{fee, _@@foo, fum}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertEqual([{foo,"fiefoe"},{post,"fum"},{pre,"fee"}],
+ fe(ok(merl:match(?Q("{_@pre, _@@foo, _@post}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertThrow({error, "multiple glob variables"++_},
+ fe(ok(merl:match(?Q("{_@@foo, _@@bar}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertEqual([],
+ fe(ok(merl:match(?Q("{fee, _@@_}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertEqual([],
+ fe(ok(merl:match(?Q("{_@@_, foe, fum}"),
+ ?Q("{fee, fie, foe, fum}"))))),
+ ?_assertEqual([{post,"fum"},{pre,"fee"}],
+ fe(ok(merl:match(?Q("{_@pre, _@@_, _@post}"),
+ ?Q("{fee, fie, foe, fum}")))))
+ ].
+
+switch_test_() ->
+ [?_assertEqual(42, merl:switch(?Q("foo"), [fun () -> 42 end])),
+ ?_assertEqual(17, merl:switch(?Q("foo"), [fun () -> 17 end,
+ fun () -> 42 end])),
+ ?_assertEqual(17, merl:switch(?Q("foo"), [{?Q("foo"),
+ fun ([]) -> 17 end},
+ fun () -> 42 end])),
+ ?_assertEqual(17,
+ merl:switch(?Q("foo"), [{?Q("bar"), fun ([]) -> 0 end},
+ {?Q("foo"), fun ([]) -> 17 end},
+ fun () -> 42 end])),
+ ?_assertEqual([{foo,"17"}],
+ merl:switch(?Q("{foo,17}"),
+ [{?Q("{bar, _@foo}"), fun (_) -> 0 end},
+ {?Q("{foo, _@foo}"), fun fe/1},
+ fun () -> 42 end])),
+ ?_assertEqual(17,
+ merl:switch(?Q("{foo, 17}"),
+ [{?Q("{foo, _@foo}"),
+ fun ([{foo, X}]) -> f(X) =:= "17" end,
+ fun (_) -> 17 end},
+ fun () -> 42 end])),
+ ?_assertEqual([{foo,"17"}],
+ merl:switch(?Q("{foo, 17}"),
+ [{?Q("{foo, _@foo}"),
+ fun ([{foo, X}]) -> f(X) =:= "42" end,
+ fun (_) -> 0 end},
+ {?Q("{foo, _@foo}"), fun fe/1},
+ fun () -> 42 end])),
+ ?_assertEqual(17,
+ merl:switch(?Q("{foo, 17}"),
+ [{?Q("{foo, _@foo}"),
+ [{fun ([{foo, X}]) -> f(X) =:= "17" end,
+ fun (_) -> 17 end},
+ fun (_) -> 0 end]},
+ fun () -> 42 end])),
+ ?_assertEqual([{foo,"17"}],
+ merl:switch(?Q("{foo, 17}"),
+ [{?Q("{foo, _@foo}"),
+ [{fun ([{foo, X}]) -> f(X) =:= "42" end,
+ fun (_) -> 0 end},
+ fun fe/1]},
+ fun () -> 42 end]))
+ ].
+
+-ifndef(MERL_NO_TRANSFORM).
+
+inline_meta_test_() ->
+ [?_assertEqual("{foo}",
+ f(begin
+ Foo = ?Q("foo"),
+ ?Q("{_@Foo}")
+ end)),
+ ?_assertEqual("{foo, '@bar'}",
+ f(begin
+ Foo = ?Q("foo"),
+ ?Q("{_@Foo,_@bar}")
+ end)),
+ ?_assertEqual("{foo, '@bar'}",
+ f(begin
+ Q1 = ?Q("foo"),
+ ?Q("{90919,_@bar}")
+ end))
+ ].
+
+inline_meta_autoabstract_test_() ->
+ [?_assertEqual("{foo}",
+ f(begin
+ Foo = foo,
+ ?Q("{_@Foo@}")
+ end)),
+ ?_assertEqual("{foo, '@bar@'}",
+ f(begin
+ Foo = foo,
+ ?Q("{_@Foo@,_@bar@}")
+ end)),
+ ?_assertEqual("{foo, '@bar@'}",
+ f(begin
+ Q1 = foo,
+ ?Q("{909199,_@bar@}")
+ end))
+ ].
+
+meta_match_test_() ->
+ [?_assertEqual("{[bar], baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ ?Q("{foo, _@Bar, '@Baz'}") = Tree,
+ ?Q("{_@Bar, _@Baz}")
+ end)),
+ ?_assertEqual("{[bar], baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ ?Q("{foo, 90919, 90929}") = Tree,
+ ?Q("{_@Q1, _@Q2}")
+ end)),
+ ?_assertError({badmatch,error},
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ ?Q("{fie, _@Bar, '@Baz'}") = Tree,
+ ?Q("{_@Bar, _@Baz}")
+ end))
+ ].
+
+meta_case_test_() ->
+ [?_assertEqual("{[bar], baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ case Tree of
+ ?Q("{foo, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}")
+ end
+ end)),
+ ?_assertEqual("{foo, [bar], baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ case Tree of
+ ?Q("{fie, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}");
+ _ -> Tree
+ end
+ end)),
+ ?_assertError(merl_switch_clause,
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ case Tree of
+ ?Q("{fie, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}")
+ end
+ end)),
+ ?_assertEqual("{foo, 4}",
+ f(begin
+ Tree = ?Q("{foo, 3}"),
+ case Tree of
+ ?Q("{foo, _@N}") ->
+ N1 = erl_syntax:concrete(N) + 1,
+ ?Q("{foo, _@N1@}");
+ _ -> Tree
+ end
+ end)),
+ ?_assertEqual("-export([f/4]).",
+ f(begin
+ Tree = ?Q("-export([f/3])."),
+ case Tree of
+ ?Q("-export([f/90919]).") ->
+ Q2 = erl_syntax:concrete(Q1) + 1,
+ ?Q("-export([f/909299]).");
+ _ -> Tree
+ end
+ end)),
+ ?_assertEqual("{1, [bar], baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ case Tree of
+ ?Q("{foo, _@Bar, '@Baz'}") ->
+ ?Q("{1, _@Bar, _@Baz}");
+ ?Q("{fie, _@Bar, '@Baz'}") ->
+ ?Q("{2, _@Bar, _@Baz}");
+ _ -> Tree
+ end
+ end)),
+ ?_assertEqual("{2, [bar], baz()}",
+ f(begin
+ Tree = ?Q("{fie, [bar], baz()}"),
+ case Tree of
+ ?Q("{foo, _@Bar, '@Baz'}") ->
+ ?Q("{1, _@Bar, _@Baz}");
+ ?Q("{fie, _@Bar, '@Baz'}") ->
+ ?Q("{2, _@Bar, _@Baz}");
+ _ -> Tree
+ end
+ end)),
+ ?_assertEqual("{2, baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ case Tree of
+ ?Q("{foo, [_@Bar], '@Baz'}")
+ when erl_syntax:is_atom(Bar, foo) ->
+ ?Q("{1, _@Baz}");
+ ?Q("{foo, [_@Bar], '@Baz'}")
+ when erl_syntax:is_atom(Bar, bar) ->
+ ?Q("{2, _@Baz}");
+ ?Q("{foo, [_@Bar], '@Baz'}") ->
+ ?Q("{3, _@Baz}");
+ _ -> Tree
+ end
+ end)),
+ ?_assertEqual("{2, 42}",
+ f(begin
+ Tree = ?Q("{foo, [bar], 42}"),
+ case Tree of
+ ?Q("{foo, [_@Bar], '@Baz'}")
+ when erl_syntax:is_atom(Bar, bar),
+ erl_syntax:is_integer(Baz, 17) ->
+ ?Q("{1, _@Bar}");
+ ?Q("{foo, [_@Bar], '@Baz'}")
+ when erl_syntax:is_atom(Bar, bar),
+ erl_syntax:is_integer(Baz, 42) ->
+ ?Q("{2, _@Baz}");
+ ?Q("{foo, [_@Bar], '@Baz'}") ->
+ ?Q("{3, _@Baz}");
+ _ -> Tree
+ end
+ end)),
+ ?_assertEqual("{2, 42}",
+ f(begin
+ Tree = ?Q("{foo, [baz], 42}"),
+ case Tree of
+ ?Q("{foo, [_@Bar], '@Baz'}")
+ when erl_syntax:is_atom(Bar, bar),
+ erl_syntax:is_integer(Baz, 17)
+ ; erl_syntax:is_atom(Bar, baz),
+ erl_syntax:is_integer(Baz, 17) ->
+ ?Q("{1, _@Bar}");
+ ?Q("{foo, [_@Bar], '@Baz'}")
+ when erl_syntax:is_atom(Bar, bar),
+ erl_syntax:is_integer(Baz, 42)
+ ; erl_syntax:is_atom(Bar, baz),
+ erl_syntax:is_integer(Baz, 42) ->
+ ?Q("{2, _@Baz}");
+ ?Q("{foo, [_@Bar], '@Baz'}") ->
+ ?Q("{3, _@Baz}");
+ _ -> Tree
+ end
+ end)),
+ ?_assertEqual("{2, foo, Bar, Baz, Bar(), Baz()}",
+ f(begin
+ Tree = ?Q("foo(Bar, Baz) -> Bar(), Baz()."),
+ case Tree of
+ ?Q("'@Func'(_@Args) -> _@Body.") ->
+ ?Q("{1, _@Func, _@Args, _@Body}");
+ ?Q("'@Func'(_@@Args) -> _@@Body.") ->
+ ?Q("{2, _@Func, _@Args, _@Body}");
+ ?Q("'@Func'(_@Args, Baz) -> _@Body1, _@Body2.") ->
+ ?Q("{3, _@Func, _@Args, _@Body1, _@Body2}")
+ end
+ end))
+ ].
+
+-endif.
diff --git a/lib/syntax_tools/src/merl_transform.erl b/lib/syntax_tools/src/merl_transform.erl
new file mode 100644
index 0000000000..66b06c8137
--- /dev/null
+++ b/lib/syntax_tools/src/merl_transform.erl
@@ -0,0 +1,262 @@
+%% ---------------------------------------------------------------------
+%% 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.
+%%
+%% @author Richard Carlsson <[email protected]>
+%% @copyright 2012-2015 Richard Carlsson
+%% @doc Parse transform for merl. Enables the use of automatic metavariables
+%% and using quasi-quotes in matches and case switches. Also optimizes calls
+%% to functions in `merl' by partially evaluating them, turning strings to
+%% templates, etc., at compile-time.
+%%
+%% Using `-include_lib("syntax_tools/include/merl.hrl").' enables this
+%% transform, unless the macro `MERL_NO_TRANSFORM' is defined first.
+
+-module(merl_transform).
+
+-export([parse_transform/2]).
+
+%% NOTE: We cannot use inline metavariables or any other parse transform
+%% features in this module, because it must be possible to compile it with
+%% the parse transform disabled!
+-include("merl.hrl").
+
+%% TODO: unroll calls to switch? it will probably get messy
+
+%% TODO: use Igor to make resulting code independent of merl at runtime?
+
+parse_transform(Forms, _Options) ->
+ erl_syntax:revert_forms(expand(erl_syntax:form_list(Forms))).
+
+expand(Tree0) ->
+ Tree = pre(Tree0),
+ post(case erl_syntax:subtrees(Tree) of
+ [] ->
+ Tree;
+ Gs ->
+ erl_syntax:update_tree(Tree,
+ [[expand(T) || T <- G] || G <- Gs])
+ end).
+
+pre(T) ->
+ merl:switch(
+ T,
+ [{?Q("merl:quote(_@line, _@text) = _@expr"),
+ fun ([{expr,_}, {line,Line}, {text,Text}]) ->
+ erl_syntax:is_literal(Text) andalso erl_syntax:is_literal(Line)
+ end,
+ fun ([{expr,Expr}, {line,Line}, {text,Text}]) ->
+ pre_expand_match(Expr, erl_syntax:concrete(Line),
+ erl_syntax:concrete(Text))
+ end},
+ {?Q(["case _@expr of",
+ " merl:quote(_@_, _@text) when _@__@_ -> _@@_; _@_@_ -> 0",
+ "end"]),
+ fun case_guard/1,
+ fun (As) -> case_body(As, T) end},
+ fun () -> T end
+ ]).
+
+case_guard([{expr,_}, {text,Text}]) ->
+ erl_syntax:is_literal(Text).
+
+case_body([{expr,Expr}, {text,_Text}], T) ->
+ pre_expand_case(Expr, erl_syntax:case_expr_clauses(T),
+ erl_syntax:get_pos(T)).
+
+post(T) ->
+ merl:switch(
+ T,
+ [{?Q("merl:_@function(_@@args)"),
+ [{fun ([{args, As}, {function, F}]) ->
+ lists:all(fun erl_syntax:is_literal/1, [F|As])
+ end,
+ fun ([{args, As}, {function, F}]) ->
+ Line = erl_syntax:get_pos(F),
+ [F1|As1] = lists:map(fun erl_syntax:concrete/1, [F|As]),
+ eval_call(Line, F1, As1, T)
+ end},
+ fun ([{args, As}, {function, F}]) ->
+ merl:switch(
+ F,
+ [{?Q("qquote"), fun ([]) -> expand_qquote(As, T, 1) end},
+ {?Q("subst"), fun ([]) -> expand_template(F, As, T) end},
+ {?Q("match"), fun ([]) -> expand_template(F, As, T) end},
+ fun () -> T end
+ ])
+ end]},
+ fun () -> T end]).
+
+expand_qquote([Line, Text, Env], T, _) ->
+ case erl_syntax:is_literal(Line) of
+ true ->
+ expand_qquote([Text, Env], T, erl_syntax:concrete(Line));
+ false ->
+ T
+ end;
+expand_qquote([Text, Env], T, Line) ->
+ case erl_syntax:is_literal(Text) of
+ true ->
+ As = [Line, erl_syntax:concrete(Text)],
+ %% expand further if possible
+ expand(merl:qquote(Line, "merl:subst(_@tree, _@env)",
+ [{tree, eval_call(Line, quote, As, T)},
+ {env, Env}]));
+ false ->
+ T
+ end;
+expand_qquote(_As, T, _StartPos) ->
+ T.
+
+expand_template(F, [Pattern | Args], T) ->
+ case erl_syntax:is_literal(Pattern) of
+ true ->
+ Line = erl_syntax:get_pos(Pattern),
+ As = [erl_syntax:concrete(Pattern)],
+ merl:qquote(Line, "merl:_@function(_@pattern, _@args)",
+ [{function, F},
+ {pattern, eval_call(Line, template, As, T)},
+ {args, Args}]);
+ false ->
+ T
+ end;
+expand_template(_F, _As, T) ->
+ T.
+
+eval_call(Line, F, As, T) ->
+ try apply(merl, F, As) of
+ T1 when F =:= quote ->
+ %% lift metavariables in a template to Erlang variables
+ Template = merl:template(T1),
+ Vars = merl:template_vars(Template),
+ case lists:any(fun is_inline_metavar/1, Vars) of
+ true when is_list(T1) ->
+ merl:qquote(Line, "merl:tree([_@template])",
+ [{template, merl:meta_template(Template)}]);
+ true ->
+ merl:qquote(Line, "merl:tree(_@template)",
+ [{template, merl:meta_template(Template)}]);
+ false ->
+ merl:term(T1)
+ end;
+ T1 ->
+ merl:term(T1)
+ catch
+ throw:_Reason -> T
+ end.
+
+pre_expand_match(Expr, Line, Text) ->
+ {Template, Out, _Vars} = rewrite_pattern(Line, Text),
+ merl:qquote(Line, "{ok, _@out} = merl:match(_@template, _@expr)",
+ [{expr, Expr},
+ {out, Out},
+ {template, erl_syntax:abstract(Template)}]).
+
+rewrite_pattern(Line, Text) ->
+ %% we must rewrite the metavariables in the pattern to use lowercase,
+ %% and then use real matching to bind the Erlang-level variables
+ T0 = merl:template(merl:quote(Line, Text)),
+ Vars = [V || V <- merl:template_vars(T0), is_inline_metavar(V)],
+ {merl:alpha(T0, [{V, var_to_tag(V)} || V <- Vars]),
+ erl_syntax:list([erl_syntax:tuple([erl_syntax:abstract(var_to_tag(V)),
+ erl_syntax:variable(var_name(V))])
+ || V <- Vars]),
+ Vars}.
+
+var_name(V) when is_integer(V) ->
+ V1 = if V > 99, (V rem 100) =:= 99 ->
+ V div 100;
+ V > 9, (V rem 10) =:= 9 ->
+ V div 10;
+ true -> V
+ end,
+ list_to_atom("Q" ++ integer_to_list(V1));
+var_name(V) -> V.
+
+var_to_tag(V) when is_integer(V) -> V;
+var_to_tag(V) ->
+ list_to_atom(string:to_lower(atom_to_list(V))).
+
+pre_expand_case(Expr, Clauses, Line) ->
+ merl:qquote(Line, "merl:switch(_@expr, _@clauses)",
+ [{clauses, erl_syntax:list([pre_expand_case_clause(C)
+ || C <- Clauses])},
+ {expr, Expr}]).
+
+pre_expand_case_clause(T) ->
+ %% note that the only allowed non ``?Q(...) -> ...'' clause is ``_ -> ...''
+ merl:switch(
+ T,
+ [{?Q("(merl:quote(_@line, _@text)) when _@__@guard -> _@@body"),
+ fun ([{body,_}, {guard,_}, {line,Line}, {text,Text}]) ->
+ erl_syntax:is_literal(Text) andalso erl_syntax:is_literal(Line)
+ end,
+ fun ([{body,Body}, {guard,Guard}, {line,Line}, {text,Text}]) ->
+ pre_expand_case_clause(Body, Guard, erl_syntax:concrete(Line),
+ erl_syntax:concrete(Text))
+ end},
+ {?Q("_ -> _@@body"),
+ fun (Env) -> merl:qquote("fun () -> _@body end", Env) end}
+ ]).
+
+pre_expand_case_clause(Body, Guard, Line, Text) ->
+ %% this is similar to a meta-match ``?Q("...") = Term''
+ %% (note that the guards may in fact be arbitrary expressions)
+ {Template, Out, Vars} = rewrite_pattern(Line, Text),
+ GuardExprs = rewrite_guard(Guard),
+ Param = [{body, Body},
+ {guard,GuardExprs},
+ {out, Out},
+ {template, erl_syntax:abstract(Template)},
+ {unused, dummy_uses(Vars)}],
+ case GuardExprs of
+ [] ->
+ merl:qquote(Line, ["{_@template, ",
+ " fun (_@out) -> _@unused, _@body end}"],
+ Param);
+ _ ->
+ merl:qquote(Line, ["{_@template, ",
+ " fun (_@out) -> _@unused, _@guard end, ",
+ " fun (_@out) -> _@unused, _@body end}"],
+ Param)
+ end.
+
+%% We have to insert dummy variable uses at the beginning of the "guard" and
+%% "body" function bodies to avoid warnings for unused variables in the
+%% generated code. (Expansions at the Erlang level can't be marked up as
+%% compiler generated to allow later compiler stages to ignore them.)
+dummy_uses(Vars) ->
+ [?Q("_ = _@var", [{var, erl_syntax:variable(var_name(V))}])
+ || V <- Vars].
+
+rewrite_guard([]) -> [];
+rewrite_guard([D]) -> [make_orelse(erl_syntax:disjunction_body(D))].
+
+make_orelse([]) -> [];
+make_orelse([C]) -> make_andalso(erl_syntax:conjunction_body(C));
+make_orelse([C | Cs]) ->
+ ?Q("_@expr orelse _@rest",
+ [{expr, make_andalso(erl_syntax:conjunction_body(C))},
+ {rest, make_orelse(Cs)}]).
+
+make_andalso([E]) -> E;
+make_andalso([E | Es]) ->
+ ?Q("_@expr andalso _@rest", [{expr, E}, {rest, make_andalso(Es)}]).
+
+is_inline_metavar(Var) when is_atom(Var) ->
+ is_erlang_var(atom_to_list(Var));
+is_inline_metavar(Var) when is_integer(Var) ->
+ Var > 9 andalso (Var rem 10) =:= 9;
+is_inline_metavar(_) -> false.
+
+is_erlang_var([C|_]) when C >= $A, C =< $Z ; C >= $À, C =< $Þ, C /= $× ->
+ true;
+is_erlang_var(_) ->
+ false.
diff --git a/lib/syntax_tools/src/syntax_tools.app.src b/lib/syntax_tools/src/syntax_tools.app.src
index 83dcb5fe23..e207901def 100644
--- a/lib/syntax_tools/src/syntax_tools.app.src
+++ b/lib/syntax_tools/src/syntax_tools.app.src
@@ -11,8 +11,10 @@
erl_syntax_lib,
erl_tidy,
igor,
+ merl,
+ merl_transform,
prettypr]},
{registered,[]},
{applications, [stdlib]},
{env, []},
- {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]}]}.
+ {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]}]}.
diff --git a/lib/syntax_tools/test/Makefile b/lib/syntax_tools/test/Makefile
index f67e3f8984..569c044b1a 100644
--- a/lib/syntax_tools/test/Makefile
+++ b/lib/syntax_tools/test/Makefile
@@ -6,7 +6,8 @@ include $(ERL_TOP)/make/$(TARGET)/otp.mk
# ----------------------------------------------------
MODULES= \
- syntax_tools_SUITE
+ syntax_tools_SUITE \
+ merl_SUITE
ERL_FILES= $(MODULES:%=%.erl)
diff --git a/lib/syntax_tools/test/merl_SUITE.erl b/lib/syntax_tools/test/merl_SUITE.erl
new file mode 100644
index 0000000000..08b0f7a696
--- /dev/null
+++ b/lib/syntax_tools/test/merl_SUITE.erl
@@ -0,0 +1,91 @@
+%% ``The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved via the world wide web at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% The Initial Developer of the Original Code is Ericsson Utvecklings AB.
+%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings
+%% AB. All Rights Reserved.''
+%%
+-module(merl_SUITE).
+
+-include_lib("test_server/include/test_server.hrl").
+
+%% include the Merl header file
+-include_lib("syntax_tools/include/merl.hrl").
+
+%% for assert macros
+-include_lib("eunit/include/eunit.hrl").
+
+%% Test server specific exports
+-export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1,
+ init_per_group/2,end_per_group/2]).
+
+%% Test cases
+-export([merl_smoke_test/1]).
+
+suite() -> [{ct_hooks,[ts_install_cth]}].
+
+all() ->
+ [merl_smoke_test].
+
+groups() ->
+ [].
+
+init_per_suite(Config) ->
+ Config.
+
+end_per_suite(_Config) ->
+ ok.
+
+init_per_group(_GroupName, Config) ->
+ Config.
+
+end_per_group(_GroupName, Config) ->
+ Config.
+
+-define(tokens2str(X), ??X).
+
+merl_smoke_test(Config) when is_list(Config) ->
+ ?assertThrow({error, "1: syntax error before: '{'" ++ _},
+ f(merl:quote("{"))),
+ ?assertEqual(tuple, erl_syntax:type(merl:term({}))),
+ ?assertEqual("{foo, 42}", f(merl:term({foo, 42}))),
+ ?assertEqual("f(X) -> {ok, X}.", f(?Q("f(X) -> {ok, X}."))),
+ ?assertEqual("{foo, 42}", f(?Q("{foo, 42}"))),
+ ?assertEqual("2 + 2", f(?Q("2 + 2"))),
+ ?assertEqual("%% comment preserved\n{foo, 42}",
+ f(?Q(["%% comment preserved", "{foo, 42}"]))),
+ ?assertEqual("'@foo'", f(merl:tree(merl:template(?Q("'@foo'"))))),
+ ?assertEqual("42", f(merl:subst(?Q("_@foo"), [{foo, merl:term(42)}]))),
+ ?assertEqual({ok, []}, merl:match(?Q("foo"), ?Q("foo"))),
+ ?assertEqual(42, merl:switch(?Q("foo"), [fun () -> 42 end])),
+ ?assertEqual("{foo}", f(begin Foo = ?Q("foo"), ?Q("{_@Foo}") end)),
+ ?assertEqual("{foo}", f(begin Foo = foo, ?Q("{_@Foo@}") end)),
+ ?assertEqual("{[bar], baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ ?Q("{foo, _@Bar, '@Baz'}") = Tree,
+ ?Q("{_@Bar, _@Baz}")
+ end)),
+ ?assertEqual("{[bar], baz()}",
+ f(begin
+ Tree = ?Q("{foo, [bar], baz()}"),
+ case Tree of
+ ?Q("{foo, _@Bar, '@Baz'}") -> ?Q("{_@Bar, _@Baz}")
+ end
+ end)),
+ ok.
+
+%% utilities
+
+f(Ts) when is_list(Ts) ->
+ lists:flatmap(fun erl_prettypr:format/1, Ts);
+f(T) ->
+ erl_prettypr:format(T).
diff --git a/lib/syntax_tools/vsn.mk b/lib/syntax_tools/vsn.mk
index 1c42ef0ddb..403e90196e 100644
--- a/lib/syntax_tools/vsn.mk
+++ b/lib/syntax_tools/vsn.mk
@@ -1 +1 @@
-SYNTAX_TOOLS_VSN = 1.6.18
+SYNTAX_TOOLS_VSN = 1.7
diff --git a/lib/tools/src/tools.app.src b/lib/tools/src/tools.app.src
index a4e5d85f92..8458941761 100644
--- a/lib/tools/src/tools.app.src
+++ b/lib/tools/src/tools.app.src
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2012. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2015. All Rights Reserved.
%%
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
@@ -40,7 +40,7 @@
{env, [{file_util_search_methods,[{"", ""}, {"ebin", "esrc"}, {"ebin", "src"}]}
]
},
- {runtime_dependencies, ["webtool-0.8.10","stdlib-2.0","runtime_tools-1.8.14",
+ {runtime_dependencies, ["webtool-0.8.10","stdlib-2.5","runtime_tools-1.8.14",
"kernel-3.0","inets-5.10","erts-7.0",
"compiler-5.0"]}
]
diff --git a/lib/tools/test/lcnt_SUITE.erl b/lib/tools/test/lcnt_SUITE.erl
index 010dffe138..de68486b1b 100644
--- a/lib/tools/test/lcnt_SUITE.erl
+++ b/lib/tools/test/lcnt_SUITE.erl
@@ -97,12 +97,12 @@ t_conflicts_file([File|Files]) ->
{ok, _} = lcnt:start(),
ok = lcnt:load(File),
ok = lcnt:conflicts(),
- THs = [-1, 0, 100, 1000],
+ THs = [-1, 5],
Print = [name , id , type , entry , tries , colls , ratio , time , duration],
Opts = [
[{sort, Sort}, {reverse, Rev}, {max_locks, ML}, {combine, Combine}, {thresholds, [TH]}, {print, [Print]}] ||
- Sort <- [name , id , type , tries , colls , ratio , time , entry],
- ML <- [none, 1 , 32, 4096],
+ Sort <- [name , type , tries , colls , ratio , time],
+ ML <- [none, 32],
Combine <- [true, false],
TH <- [{tries, Tries} || Tries <- THs] ++ [{colls, Colls} || Colls <- THs] ++ [{time, Time} || Time <- THs],
Rev <- [true, false]
@@ -131,12 +131,12 @@ t_locations_file([File|Files]) ->
{ok, _} = lcnt:start(),
ok = lcnt:load(File),
ok = lcnt:locations(),
- THs = [-1, 0, 100, 1000],
+ THs = [-1, 0, 100],
Print = [name , id , type , entry , tries , colls , ratio , time , duration],
Opts = [
[{full_id, Id}, {sort, Sort}, {max_locks, ML}, {combine, Combine}, {thresholds, [TH]}, {print, Print}] ||
Sort <- [name , id , type , tries , colls , ratio , time , entry],
- ML <- [none, 1 , 64],
+ ML <- [none, 64],
Combine <- [true, false],
TH <- [{tries, Tries} || Tries <- THs] ++ [{colls, Colls} || Colls <- THs] ++ [{time, Time} || Time <- THs],
Id <- [true, false]
diff --git a/lib/tools/vsn.mk b/lib/tools/vsn.mk
index 3b3202d38b..68c3f6e29c 100644
--- a/lib/tools/vsn.mk
+++ b/lib/tools/vsn.mk
@@ -1 +1 @@
-TOOLS_VSN = 2.7.2
+TOOLS_VSN = 2.8
diff --git a/lib/typer/vsn.mk b/lib/typer/vsn.mk
index ce658e257b..74c0ccfc59 100644
--- a/lib/typer/vsn.mk
+++ b/lib/typer/vsn.mk
@@ -1 +1 @@
-TYPER_VSN = 0.9.8
+TYPER_VSN = 0.9.9
diff --git a/lib/wx/vsn.mk b/lib/wx/vsn.mk
index 942d4c0d6f..09fb9f384c 100644
--- a/lib/wx/vsn.mk
+++ b/lib/wx/vsn.mk
@@ -1 +1 @@
-WX_VSN = 1.3.3
+WX_VSN = 1.4
diff --git a/lib/xmerl/src/xmerl.app.src b/lib/xmerl/src/xmerl.app.src
index 45cfe9d250..aed9cf176f 100644
--- a/lib/xmerl/src/xmerl.app.src
+++ b/lib/xmerl/src/xmerl.app.src
@@ -40,5 +40,5 @@
{registered, []},
{env, []},
{applications, [kernel, stdlib]},
- {runtime_dependencies, ["stdlib-2.0","kernel-3.0","erts-6.0"]}
+ {runtime_dependencies, ["stdlib-2.5","kernel-3.0","erts-6.0"]}
]}.