aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--bootstrap/lib/compiler/ebin/compile.beambin39328 -> 39368 bytes
-rw-r--r--bootstrap/lib/compiler/ebin/compiler.app4
-rw-r--r--bootstrap/lib/kernel/ebin/inet_dns.beambin19768 -> 19808 bytes
-rw-r--r--bootstrap/lib/kernel/ebin/inet_tcp_dist.beambin6876 -> 6808 bytes
-rw-r--r--bootstrap/lib/kernel/ebin/kernel.app2
-rw-r--r--bootstrap/lib/stdlib/ebin/c.beambin14096 -> 14660 bytes
-rw-r--r--bootstrap/lib/stdlib/ebin/erl_anno.beambin5060 -> 5008 bytes
-rw-r--r--bootstrap/lib/stdlib/ebin/erl_lint.beambin89616 -> 89464 bytes
-rw-r--r--bootstrap/lib/stdlib/ebin/ets.beambin22396 -> 22604 bytes
-rw-r--r--bootstrap/lib/stdlib/ebin/shell_default.beambin3884 -> 3932 bytes
-rw-r--r--bootstrap/lib/stdlib/ebin/stdlib.app2
-rw-r--r--erts/configure.in1
-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/etc/ose/run_erl.c2
-rw-r--r--erts/preloaded/src/erts.app.src2
-rw-r--r--lib/.gitignore2
-rw-r--r--lib/asn1/doc/src/asn1ct.xml18
-rw-r--r--lib/compiler/src/beam_bsm.erl6
-rw-r--r--lib/compiler/src/compile.erl6
-rw-r--r--lib/compiler/src/compiler.app.src4
-rw-r--r--lib/compiler/test/warnings_SUITE.erl17
-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/debugger/src/debugger.app.src4
-rw-r--r--lib/dialyzer/src/dialyzer.app.src4
-rw-r--r--lib/edoc/src/edoc.app.src2
-rw-r--r--lib/erl_docgen/src/erl_docgen.app.src2
-rw-r--r--lib/eunit/src/eunit.app.src2
-rw-r--r--lib/hipe/main/hipe.app.src4
-rw-r--r--lib/kernel/src/application_controller.erl3
-rw-r--r--lib/kernel/src/code.erl11
-rw-r--r--lib/kernel/src/inet_parse.erl30
-rw-r--r--lib/kernel/src/kernel.app.src2
-rw-r--r--lib/kernel/src/user_drv.erl48
-rw-r--r--lib/kernel/test/inet_SUITE.erl3
-rw-r--r--lib/megaco/src/app/megaco.app.src4
-rw-r--r--lib/megaco/vsn.mk4
-rw-r--r--lib/parsetools/src/parsetools.app.src2
-rw-r--r--lib/snmp/src/app/snmp.app.src4
-rw-r--r--lib/snmp/vsn.mk2
-rw-r--r--lib/ssh/src/ssh_connection_handler.erl249
-rw-r--r--lib/ssh/test/Makefile3
-rw-r--r--lib/ssh/test/ssh_basic_SUITE.erl177
-rw-r--r--lib/ssh/test/ssh_relay.erl407
-rw-r--r--lib/ssl/test/ssl_alpn_handshake_SUITE.erl6
-rw-r--r--lib/ssl/test/ssl_basic_SUITE.erl10
-rw-r--r--lib/ssl/test/ssl_npn_handshake_SUITE.erl6
-rw-r--r--lib/ssl/test/ssl_sni_SUITE.erl51
-rw-r--r--lib/ssl/test/ssl_test_lib.erl3
-rw-r--r--lib/ssl/test/ssl_to_openssl_SUITE.erl53
-rw-r--r--lib/stdlib/doc/src/ets.xml4
-rw-r--r--lib/stdlib/src/erl_lint.erl66
-rw-r--r--lib/stdlib/src/ets.erl43
-rw-r--r--lib/stdlib/src/stdlib.app.src2
-rw-r--r--lib/stdlib/test/ets_SUITE.erl17
-rw-r--r--lib/stdlib/test/maps_SUITE.erl7
-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/tools/src/tools.app.src4
-rw-r--r--lib/wx/c_src/wxe_driver.c11
-rw-r--r--lib/wx/c_src/wxe_impl.cpp14
-rw-r--r--lib/wx/c_src/wxe_impl.h3
-rw-r--r--lib/xmerl/src/xmerl.app.src2
84 files changed, 4367 insertions, 621 deletions
diff --git a/bootstrap/lib/compiler/ebin/compile.beam b/bootstrap/lib/compiler/ebin/compile.beam
index e648a70b2f..111f85acd2 100644
--- a/bootstrap/lib/compiler/ebin/compile.beam
+++ b/bootstrap/lib/compiler/ebin/compile.beam
Binary files differ
diff --git a/bootstrap/lib/compiler/ebin/compiler.app b/bootstrap/lib/compiler/ebin/compiler.app
index 39635bd447..dfe077d5b9 100644
--- a/bootstrap/lib/compiler/ebin/compiler.app
+++ b/bootstrap/lib/compiler/ebin/compiler.app
@@ -69,5 +69,5 @@
{registered, []},
{applications, [kernel, stdlib]},
{env, []},
- {runtime_dependencies, ["stdlib-2.0","kernel-3.0","hipe-3.10.3","erts-7.0",
- "crypto-3.3"]}]}.
+ {runtime_dependencies, ["stdlib-2.5","kernel-4.0","hipe-3.12","erts-7.0",
+ "crypto-3.6"]}]}.
diff --git a/bootstrap/lib/kernel/ebin/inet_dns.beam b/bootstrap/lib/kernel/ebin/inet_dns.beam
index bd625968a2..0c5b6c73e1 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_tcp_dist.beam b/bootstrap/lib/kernel/ebin/inet_tcp_dist.beam
index c322eb9fdc..a3635e5dde 100644
--- a/bootstrap/lib/kernel/ebin/inet_tcp_dist.beam
+++ b/bootstrap/lib/kernel/ebin/inet_tcp_dist.beam
Binary files differ
diff --git a/bootstrap/lib/kernel/ebin/kernel.app b/bootstrap/lib/kernel/ebin/kernel.app
index e2cc4bac63..bfeea49e91 100644
--- a/bootstrap/lib/kernel/ebin/kernel.app
+++ b/bootstrap/lib/kernel/ebin/kernel.app
@@ -115,6 +115,6 @@
{applications, []},
{env, [{error_logger, tty}]},
{mod, {kernel, []}},
- {runtime_dependencies, ["erts-7.0", "stdlib-2.0", "sasl-2.4"]}
+ {runtime_dependencies, ["erts-7.0", "stdlib-2.5", "sasl-2.4"]}
]
}.
diff --git a/bootstrap/lib/stdlib/ebin/c.beam b/bootstrap/lib/stdlib/ebin/c.beam
index a08df44eb7..0e07dc1531 100644
--- a/bootstrap/lib/stdlib/ebin/c.beam
+++ b/bootstrap/lib/stdlib/ebin/c.beam
Binary files differ
diff --git a/bootstrap/lib/stdlib/ebin/erl_anno.beam b/bootstrap/lib/stdlib/ebin/erl_anno.beam
index f30442bc06..a07f730e99 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 7c80cbe624..5a8bc2a7f1 100644
--- a/bootstrap/lib/stdlib/ebin/erl_lint.beam
+++ b/bootstrap/lib/stdlib/ebin/erl_lint.beam
Binary files differ
diff --git a/bootstrap/lib/stdlib/ebin/ets.beam b/bootstrap/lib/stdlib/ebin/ets.beam
index 6f2085cf22..7d30fc9fc1 100644
--- a/bootstrap/lib/stdlib/ebin/ets.beam
+++ b/bootstrap/lib/stdlib/ebin/ets.beam
Binary files differ
diff --git a/bootstrap/lib/stdlib/ebin/shell_default.beam b/bootstrap/lib/stdlib/ebin/shell_default.beam
index fa64e33080..f295c9f116 100644
--- a/bootstrap/lib/stdlib/ebin/shell_default.beam
+++ b/bootstrap/lib/stdlib/ebin/shell_default.beam
Binary files differ
diff --git a/bootstrap/lib/stdlib/ebin/stdlib.app b/bootstrap/lib/stdlib/ebin/stdlib.app
index 50eb39d712..92ecc16b4c 100644
--- a/bootstrap/lib/stdlib/ebin/stdlib.app
+++ b/bootstrap/lib/stdlib/ebin/stdlib.app
@@ -104,7 +104,7 @@
dets]},
{applications, [kernel]},
{env, []},
- {runtime_dependencies, ["sasl-2.4","kernel-3.0.2","erts-7.0","crypto-3.3",
+ {runtime_dependencies, ["sasl-2.4","kernel-4.0","erts-7.0","crypto-3.3",
"compiler-5.0"]}
]}.
diff --git a/erts/configure.in b/erts/configure.in
index 62515fe081..39d3c51e3f 100644
--- a/erts/configure.in
+++ b/erts/configure.in
@@ -649,6 +649,7 @@ case $chk_arch_ in
powerpc) ARCH=ppc;;
ppc) ARCH=ppc;;
ppc64) ARCH=ppc64;;
+ ppc64le) ARCH=ppc64;;
"Power Macintosh") ARCH=ppc;;
armv5b) ARCH=arm;;
armv5teb) ARCH=arm;;
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/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/erts/preloaded/src/erts.app.src b/erts/preloaded/src/erts.app.src
index 345a6ae3be..cf9a06599a 100644
--- a/erts/preloaded/src/erts.app.src
+++ b/erts/preloaded/src/erts.app.src
@@ -35,7 +35,7 @@
{registered, []},
{applications, []},
{env, []},
- {runtime_dependencies, ["stdlib-2.0", "kernel-3.0", "sasl-2.4"]}
+ {runtime_dependencies, ["stdlib-2.5", "kernel-4.0", "sasl-2.4"]}
]}.
%% vim: ft=erlang
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/compiler/src/beam_bsm.erl b/lib/compiler/src/beam_bsm.erl
index 2a15c1ddf3..ee3e88959d 100644
--- a/lib/compiler/src/beam_bsm.erl
+++ b/lib/compiler/src/beam_bsm.erl
@@ -242,6 +242,12 @@ btb_reaches_match_2([{bif,_,{f,F},Ss,Dst}=I|Is], Regs0, D0) ->
Regs = btb_kill([Dst], Regs0),
D = btb_follow_branch(F, Regs, D0),
btb_reaches_match_1(Is, Regs, D);
+btb_reaches_match_2([{get_map_elements,{f,F},Src,{list,Ls}}=I|Is], Regs0, D0) ->
+ {Ss,Ds} = beam_utils:split_even(Ls),
+ btb_ensure_not_used([Src|Ss], I, Regs0),
+ Regs = btb_kill(Ds, Regs0),
+ D = btb_follow_branch(F, Regs, D0),
+ btb_reaches_match_1(Is, Regs, D);
btb_reaches_match_2([{test,bs_start_match2,{f,F},Live,[Ctx,_],Ctx}=I|Is],
Regs0, D0) ->
CtxRegs = btb_context_regs(Regs0),
diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl
index 22810c910c..0158cf64db 100644
--- a/lib/compiler/src/compile.erl
+++ b/lib/compiler/src/compile.erl
@@ -342,10 +342,10 @@ run_tc({Name,Fun}, St) ->
run_eprof({Name,Fun}, Name, St) ->
io:format("~p: Running eprof\n", [Name]),
- eprof:start_profiling([self()]),
+ c:appcall(tools, eprof, start_profiling, [[self()]]),
Val = (catch Fun(St)),
- eprof:stop_profiling(),
- eprof:analyze(),
+ c:appcall(tools, eprof, stop_profiling, []),
+ c:appcall(tools, eprof, analyze, []),
Val;
run_eprof({_,Fun}, _, St) ->
catch Fun(St).
diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src
index 2a40c1c379..17d1bd91ce 100644
--- a/lib/compiler/src/compiler.app.src
+++ b/lib/compiler/src/compiler.app.src
@@ -69,5 +69,5 @@
{registered, []},
{applications, [kernel, stdlib]},
{env, []},
- {runtime_dependencies, ["stdlib-2.0","kernel-3.0","hipe-3.10.3","erts-7.0",
- "crypto-3.3"]}]}.
+ {runtime_dependencies, ["stdlib-2.5","kernel-4.0","hipe-3.12","erts-7.0",
+ "crypto-3.6"]}]}.
diff --git a/lib/compiler/test/warnings_SUITE.erl b/lib/compiler/test/warnings_SUITE.erl
index f6ba75577d..5742b7e6cf 100644
--- a/lib/compiler/test/warnings_SUITE.erl
+++ b/lib/compiler/test/warnings_SUITE.erl
@@ -38,7 +38,8 @@
-export([pattern/1,pattern2/1,pattern3/1,pattern4/1,
guard/1,bad_arith/1,bool_cases/1,bad_apply/1,
files/1,effect/1,bin_opt_info/1,bin_construction/1,
- comprehensions/1,maps/1,redundant_boolean_clauses/1,
+ comprehensions/1,maps/1,maps_bin_opt_info/1,
+ redundant_boolean_clauses/1,
latin1_fallback/1,underscore/1,no_warnings/1]).
% Default timetrap timeout (set in init_per_testcase).
@@ -64,6 +65,7 @@ groups() ->
[pattern,pattern2,pattern3,pattern4,guard,
bad_arith,bool_cases,bad_apply,files,effect,
bin_opt_info,bin_construction,comprehensions,maps,
+ maps_bin_opt_info,
redundant_boolean_clauses,latin1_fallback,
underscore,no_warnings]}].
@@ -619,6 +621,19 @@ maps(Config) when is_list(Config) ->
run(Config, Ts),
ok.
+maps_bin_opt_info(Config) when is_list(Config) ->
+ Ts = [{map_bsm,
+ <<"
+ t1(<<0:8,7:8,T/binary>>,#{val := I}=M) ->
+ t1(T, M#{val := I+1});
+ t1(<<_:8>>,M) ->
+ M.
+ ">>,
+ [bin_opt_info],
+ {warnings,[{2,beam_bsm,bin_opt}]}}],
+ [] = run(Config, Ts),
+ ok.
+
redundant_boolean_clauses(Config) when is_list(Config) ->
Ts = [{redundant_boolean_clauses,
<<"
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/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/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/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/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/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/kernel/src/application_controller.erl b/lib/kernel/src/application_controller.erl
index 6635885aaf..a1a99a4e18 100644
--- a/lib/kernel/src/application_controller.erl
+++ b/lib/kernel/src/application_controller.erl
@@ -490,7 +490,8 @@ init(Init, Kernel) ->
%% called during start-up of any app.
case check_conf_data(ConfData) of
ok ->
- _ = ets:new(ac_tab, [set, public, named_table]),
+ _ = ets:new(ac_tab, [set, public, named_table,
+ {read_concurrency,true}]),
S = #state{conf_data = ConfData},
{ok, KAppl} = make_appl(Kernel),
case catch load(S, KAppl) of
diff --git a/lib/kernel/src/code.erl b/lib/kernel/src/code.erl
index d73d1ff281..65045666ec 100644
--- a/lib/kernel/src/code.erl
+++ b/lib/kernel/src/code.erl
@@ -107,7 +107,7 @@ is_module_native(_) ->
-spec make_stub_module(Module, Beam, Info) -> Module when
Module :: module(),
Beam :: binary(),
- Info :: {list(), list()}.
+ Info :: {list(), list(), binary()}.
make_stub_module(_, _, _) ->
erlang:nif_error(undef).
@@ -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.app.src b/lib/kernel/src/kernel.app.src
index 0cb10791d7..9787dca162 100644
--- a/lib/kernel/src/kernel.app.src
+++ b/lib/kernel/src/kernel.app.src
@@ -115,6 +115,6 @@
{applications, []},
{env, [{error_logger, tty}]},
{mod, {kernel, []}},
- {runtime_dependencies, ["erts-7.0", "stdlib-2.0", "sasl-2.4"]}
+ {runtime_dependencies, ["erts-7.0", "stdlib-2.5", "sasl-2.4"]}
]
}.
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/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/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/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/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/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/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl
index 2c7f132916..65208ae158 100644
--- a/lib/ssh/src/ssh_connection_handler.erl
+++ b/lib/ssh/src/ssh_connection_handler.erl
@@ -71,6 +71,7 @@
key_exchange_init_msg, % #ssh_msg_kexinit{}
renegotiate = false, % boolean()
last_size_rekey = 0,
+ event_queue = [],
connection_queue,
address,
port,
@@ -83,6 +84,11 @@
{next_state, state_name(), term(), timeout()} |
{stop, term(), term()}.
+-type gen_fsm_sync_return() :: {next_state, state_name(), term()} |
+ {next_state, state_name(), term(), timeout()} |
+ {reply, term(), state_name(), term()} |
+ {stop, term(), term(), term()}.
+
%%====================================================================
%% Internal application API
%%====================================================================
@@ -433,9 +439,7 @@ key_exchange(#ssh_msg_kex_dh_gex_reply{} = Msg,
new_keys(#ssh_msg_newkeys{} = Msg, #state{ssh_params = Ssh0} = State0) ->
{ok, Ssh} = ssh_transport:handle_new_keys(Msg, Ssh0),
- {NextStateName, State} =
- after_new_keys(State0#state{ssh_params = Ssh}),
- {next_state, NextStateName, next_packet(State)}.
+ after_new_keys(next_packet(State0#state{ssh_params = Ssh})).
%%--------------------------------------------------------------------
-spec userauth(#ssh_msg_service_request{} | #ssh_msg_service_accept{} |
@@ -559,11 +563,13 @@ userauth(#ssh_msg_userauth_banner{message = Msg},
-spec connected({#ssh_msg_kexinit{}, binary()}, %%| %% #ssh_msg_kexdh_init{},
#state{}) -> gen_fsm_state_return().
%%--------------------------------------------------------------------
-connected({#ssh_msg_kexinit{}, _Payload} = Event, State) ->
- kexinit(Event, State#state{renegotiate = true}).
-%% ;
-%% connected(#ssh_msg_kexdh_init{} = Event, State) ->
-%% key_exchange(Event, State#state{renegotiate = true}).
+connected({#ssh_msg_kexinit{}, _Payload} = Event, #state{ssh_params = Ssh0} = State0) ->
+ {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh0),
+ State = State0#state{ssh_params = Ssh,
+ key_exchange_init_msg = KeyInitMsg,
+ renegotiate = true},
+ send_msg(SshPacket, State),
+ kexinit(Event, State).
%%--------------------------------------------------------------------
-spec handle_event(#ssh_msg_disconnect{} | #ssh_msg_ignore{} | #ssh_msg_debug{} |
@@ -592,33 +598,6 @@ handle_event(#ssh_msg_debug{always_display = Display, message = DbgMsg, language
handle_event(#ssh_msg_unimplemented{}, StateName, State) ->
{next_state, StateName, next_packet(State)};
-handle_event({adjust_window, ChannelId, Bytes}, StateName,
- #state{connection_state =
- #connection{channel_cache = Cache}} = State0) ->
- State =
- case ssh_channel:cache_lookup(Cache, ChannelId) of
- #channel{recv_window_size = WinSize, remote_id = Id} = Channel ->
- ssh_channel:cache_update(Cache, Channel#channel{recv_window_size =
- WinSize + Bytes}),
- Msg = ssh_connection:channel_adjust_window_msg(Id, Bytes),
- send_replies([{connection_reply, Msg}], State0);
- undefined ->
- State0
- end,
- {next_state, StateName, next_packet(State)};
-
-handle_event({reply_request, success, ChannelId}, StateName,
- #state{connection_state =
- #connection{channel_cache = Cache}} = State0) ->
- State = case ssh_channel:cache_lookup(Cache, ChannelId) of
- #channel{remote_id = RemoteId} ->
- Msg = ssh_connection:channel_success_msg(RemoteId),
- send_replies([{connection_reply, Msg}], State0);
- undefined ->
- State0
- end,
- {next_state, StateName, State};
-
handle_event(renegotiate, connected, #state{ssh_params = Ssh0}
= State) ->
{KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh0),
@@ -630,8 +609,7 @@ handle_event(renegotiate, connected, #state{ssh_params = Ssh0}
renegotiate = true})};
handle_event(renegotiate, StateName, State) ->
- timer:apply_after(?REKEY_TIMOUT, gen_fsm, send_all_state_event, [self(), renegotiate]),
- %% Allready in keyexcahange so ignore
+ %% Already in key-exchange so safe to ignore
{next_state, StateName, State};
%% Rekey due to sent data limit reached?
@@ -653,6 +631,38 @@ handle_event(data_size, connected, #state{ssh_params = Ssh0} = State) ->
{next_state, connected, next_packet(State)}
end;
handle_event(data_size, StateName, State) ->
+ %% Already in key-exchange so safe to ignore
+ {next_state, StateName, State};
+
+handle_event(Event, StateName, State) when StateName /= connected ->
+ Events = [{event, Event} | State#state.event_queue],
+ {next_state, StateName, State#state{event_queue = Events}};
+
+handle_event({adjust_window, ChannelId, Bytes}, StateName,
+ #state{connection_state =
+ #connection{channel_cache = Cache}} = State0) ->
+ State =
+ case ssh_channel:cache_lookup(Cache, ChannelId) of
+ #channel{recv_window_size = WinSize, remote_id = Id} = Channel ->
+ ssh_channel:cache_update(Cache, Channel#channel{recv_window_size =
+ WinSize + Bytes}),
+ Msg = ssh_connection:channel_adjust_window_msg(Id, Bytes),
+ send_replies([{connection_reply, Msg}], State0);
+ undefined ->
+ State0
+ end,
+ {next_state, StateName, next_packet(State)};
+
+handle_event({reply_request, success, ChannelId}, StateName,
+ #state{connection_state =
+ #connection{channel_cache = Cache}} = State0) ->
+ State = case ssh_channel:cache_lookup(Cache, ChannelId) of
+ #channel{remote_id = RemoteId} ->
+ Msg = ssh_connection:channel_success_msg(RemoteId),
+ send_replies([{connection_reply, Msg}], State0);
+ undefined ->
+ State0
+ end,
{next_state, StateName, State};
handle_event({request, ChannelPid, ChannelId, Type, Data}, StateName, State0) ->
@@ -683,8 +693,65 @@ handle_event({unknown, Data}, StateName, State) ->
sockname]} | {channel_info, channel_id(), [recv_window |
send_window]} |
{close, channel_id()} | stop, term(), state_name(), #state{})
- -> gen_fsm_state_return().
+ -> gen_fsm_sync_return().
%%--------------------------------------------------------------------
+handle_sync_event(get_print_info, _From, StateName, State) ->
+ Reply =
+ try
+ {inet:sockname(State#state.socket),
+ inet:peername(State#state.socket)
+ }
+ of
+ {{ok,Local}, {ok,Remote}} -> {{Local,Remote},io_lib:format("statename=~p",[StateName])};
+ _ -> {{"-",0},"-"}
+ catch
+ _:_ -> {{"?",0},"?"}
+ end,
+ {reply, Reply, StateName, State};
+
+handle_sync_event({connection_info, Options}, _From, StateName, State) ->
+ Info = ssh_info(Options, State, []),
+ {reply, Info, StateName, State};
+
+handle_sync_event({channel_info, ChannelId, Options}, _From, StateName,
+ #state{connection_state = #connection{channel_cache = Cache}} = State) ->
+ case ssh_channel:cache_lookup(Cache, ChannelId) of
+ #channel{} = Channel ->
+ Info = ssh_channel_info(Options, Channel, []),
+ {reply, Info, StateName, State};
+ undefined ->
+ {reply, [], StateName, State}
+ end;
+
+handle_sync_event({info, ChannelPid}, _From, StateName,
+ #state{connection_state =
+ #connection{channel_cache = Cache}} = State) ->
+ Result = ssh_channel:cache_foldl(
+ fun(Channel, Acc) when ChannelPid == all;
+ Channel#channel.user == ChannelPid ->
+ [Channel | Acc];
+ (_, Acc) ->
+ Acc
+ end, [], Cache),
+ {reply, {ok, Result}, StateName, State};
+
+handle_sync_event(stop, _, _StateName, #state{connection_state = Connection0,
+ role = Role,
+ opts = Opts} = State0) ->
+ {disconnect, Reason, {{replies, Replies}, Connection}} =
+ ssh_connection:handle_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION,
+ description = "User closed down connection",
+ language = "en"}, Connection0, Role),
+ State = send_replies(Replies, State0),
+ SSHOpts = proplists:get_value(ssh_opts, Opts),
+ disconnect_fun(Reason, SSHOpts),
+ {stop, normal, ok, State#state{connection_state = Connection}};
+
+
+handle_sync_event(Event, From, StateName, State) when StateName /= connected ->
+ Events = [{sync, Event, From} | State#state.event_queue],
+ {next_state, StateName, State#state{event_queue = Events}};
+
handle_sync_event({request, ChannelPid, ChannelId, Type, Data, Timeout}, From, StateName, State0) ->
{{replies, Replies}, State1} = handle_request(ChannelPid,
ChannelId, Type, Data,
@@ -787,46 +854,6 @@ handle_sync_event({recv_window, ChannelId}, _From, StateName,
end,
{reply, Reply, StateName, next_packet(State)};
-handle_sync_event(get_print_info, _From, StateName, State) ->
- Reply =
- try
- {inet:sockname(State#state.socket),
- inet:peername(State#state.socket)
- }
- of
- {{ok,Local}, {ok,Remote}} -> {{Local,Remote},io_lib:format("statename=~p",[StateName])};
- _ -> {{"-",0},"-"}
- catch
- _:_ -> {{"?",0},"?"}
- end,
- {reply, Reply, StateName, State};
-
-handle_sync_event({connection_info, Options}, _From, StateName, State) ->
- Info = ssh_info(Options, State, []),
- {reply, Info, StateName, State};
-
-handle_sync_event({channel_info, ChannelId, Options}, _From, StateName,
- #state{connection_state = #connection{channel_cache = Cache}} = State) ->
- case ssh_channel:cache_lookup(Cache, ChannelId) of
- #channel{} = Channel ->
- Info = ssh_channel_info(Options, Channel, []),
- {reply, Info, StateName, State};
- undefined ->
- {reply, [], StateName, State}
- end;
-
-handle_sync_event({info, ChannelPid}, _From, StateName,
- #state{connection_state =
- #connection{channel_cache = Cache}} = State) ->
- Result = ssh_channel:cache_foldl(
- fun(Channel, Acc) when ChannelPid == all;
- Channel#channel.user == ChannelPid ->
- [Channel | Acc];
- (_, Acc) ->
- Acc
- end, [], Cache),
- {reply, {ok, Result}, StateName, State};
-
handle_sync_event({close, ChannelId}, _, StateName,
#state{connection_state =
#connection{channel_cache = Cache}} = State0) ->
@@ -841,19 +868,7 @@ handle_sync_event({close, ChannelId}, _, StateName,
undefined ->
State0
end,
- {reply, ok, StateName, next_packet(State)};
-
-handle_sync_event(stop, _, _StateName, #state{connection_state = Connection0,
- role = Role,
- opts = Opts} = State0) ->
- {disconnect, Reason, {{replies, Replies}, Connection}} =
- ssh_connection:handle_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION,
- description = "User closed down connection",
- language = "en"}, Connection0, Role),
- State = send_replies(Replies, State0),
- SSHOpts = proplists:get_value(ssh_opts, Opts),
- disconnect_fun(Reason, SSHOpts),
- {stop, normal, ok, State#state{connection_state = Connection}}.
+ {reply, ok, StateName, next_packet(State)}.
%%--------------------------------------------------------------------
-spec handle_info({atom(), port(), binary()} | {atom(), port()} |
@@ -1282,8 +1297,17 @@ generate_event(<<?BYTE(Byte), _/binary>> = Msg, StateName,
ConnectionMsg = ssh_message:decode(Msg),
State1 = generate_event_new_state(State0, EncData),
try ssh_connection:handle_msg(ConnectionMsg, Connection0, Role) of
- {{replies, Replies}, Connection} ->
- State = send_replies(Replies, State1#state{connection_state = Connection}),
+ {{replies, Replies0}, Connection} ->
+ if StateName == connected ->
+ Replies = Replies0,
+ State2 = State1;
+ true ->
+ {ConnReplies, Replies} =
+ lists:splitwith(fun not_connected_filter/1, Replies0),
+ Q = State1#state.event_queue ++ ConnReplies,
+ State2 = State1#state{ event_queue = Q }
+ end,
+ State = send_replies(Replies, State2#state{connection_state = Connection}),
{next_state, StateName, next_packet(State)};
{noreply, Connection} ->
{next_state, StateName, next_packet(State1#state{connection_state = Connection})};
@@ -1456,15 +1480,43 @@ next_packet(#state{socket = Socket} = State) ->
State.
after_new_keys(#state{renegotiate = true} = State) ->
- {connected, State#state{renegotiate = false}};
+ State1 = State#state{renegotiate = false, event_queue = []},
+ lists:foldr(fun after_new_keys_events/2, {next_state, connected, State1}, State#state.event_queue);
after_new_keys(#state{renegotiate = false,
ssh_params = #ssh{role = client} = Ssh0} = State) ->
{Msg, Ssh} = ssh_auth:service_request_msg(Ssh0),
send_msg(Msg, State),
- {userauth, State#state{ssh_params = Ssh}};
+ {next_state, userauth, State#state{ssh_params = Ssh}};
after_new_keys(#state{renegotiate = false,
ssh_params = #ssh{role = server}} = State) ->
- {userauth, State}.
+ {next_state, userauth, State}.
+
+after_new_keys_events({sync, _Event, From}, {stop, _Reason, _StateData}=Terminator) ->
+ gen_fsm:reply(From, {error, closed}),
+ Terminator;
+after_new_keys_events(_, {stop, _Reason, _StateData}=Terminator) ->
+ Terminator;
+after_new_keys_events({sync, Event, From}, {next_state, StateName, StateData}) ->
+ case handle_sync_event(Event, From, StateName, StateData) of
+ {reply, Reply, NextStateName, NewStateData} ->
+ gen_fsm:reply(From, Reply),
+ {next_state, NextStateName, NewStateData};
+ {next_state, NextStateName, NewStateData}->
+ {next_state, NextStateName, NewStateData};
+ {stop, Reason, Reply, NewStateData} ->
+ gen_fsm:reply(From, Reply),
+ {stop, Reason, NewStateData}
+ end;
+after_new_keys_events({event, Event}, {next_state, StateName, StateData}) ->
+ case handle_event(Event, StateName, StateData) of
+ {next_state, NextStateName, NewStateData}->
+ {next_state, NextStateName, NewStateData};
+ {stop, Reason, NewStateData} ->
+ {stop, Reason, NewStateData}
+ end;
+after_new_keys_events({connection_reply, _Data} = Reply, {StateName, State}) ->
+ NewState = send_replies([Reply], State),
+ {next_state, StateName, NewState}.
handle_ssh_packet_data(RemainingSshPacketLen, DecData, EncData, StateName,
State) ->
@@ -1625,6 +1677,11 @@ log_error(Reason) ->
error_logger:error_report(Report),
"Internal error".
+not_connected_filter({connection_reply, _Data}) ->
+ true;
+not_connected_filter(_) ->
+ false.
+
send_replies([], State) ->
State;
send_replies([{connection_reply, Data} | Rest], #state{ssh_params = Ssh0} = State) ->
diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile
index 740dbd0235..39b2f57d26 100644
--- a/lib/ssh/test/Makefile
+++ b/lib/ssh/test/Makefile
@@ -40,7 +40,8 @@ MODULES= \
ssh_connection_SUITE \
ssh_echo_server \
ssh_peername_sockname_server \
- ssh_test_cli
+ ssh_test_cli \
+ ssh_relay
HRL_FILES_NEEDED_IN_TEST= \
$(ERL_TOP)/lib/ssh/src/ssh.hrl \
diff --git a/lib/ssh/test/ssh_basic_SUITE.erl b/lib/ssh/test/ssh_basic_SUITE.erl
index 242c9a3bd9..aaf0fa9905 100644
--- a/lib/ssh/test/ssh_basic_SUITE.erl
+++ b/lib/ssh/test/ssh_basic_SUITE.erl
@@ -29,6 +29,7 @@
-define(NEWLINE, <<"\r\n">>).
+-define(REKEY_DATA_TMO, 65000).
%%--------------------------------------------------------------------
%% Common Test interface functions -----------------------------------
%%--------------------------------------------------------------------
@@ -44,6 +45,7 @@ all() ->
{group, dsa_pass_key},
{group, rsa_pass_key},
{group, internal_error},
+ {group, renegotiate},
daemon_already_started,
server_password_option,
server_userpassword_option,
@@ -69,6 +71,7 @@ groups() ->
{dsa_pass_key, [], [pass_phrase]},
{rsa_pass_key, [], [pass_phrase]},
{internal_error, [], [internal_error]},
+ {renegotiate, [], [rekey, rekey_limit, renegotiate1, renegotiate2]},
{hardening_tests, [], [ssh_connect_nonegtimeout_connected_parallel,
ssh_connect_nonegtimeout_connected_sequential,
ssh_connect_negtimeout_parallel,
@@ -84,8 +87,7 @@ groups() ->
basic_tests() ->
[send, close, peername_sockname,
exec, exec_compressed, shell, cli, known_hosts,
- idle_time, rekey, openssh_zlib_basic_test,
- misc_ssh_options, inet_option].
+ idle_time, openssh_zlib_basic_test, misc_ssh_options, inet_option].
%%--------------------------------------------------------------------
@@ -333,25 +335,175 @@ idle_time(Config) ->
rekey() ->
[{doc, "Idle timeout test"}].
rekey(Config) ->
- SystemDir = filename:join(?config(priv_dir, Config), system),
+ SystemDir = ?config(data_dir, Config),
UserDir = ?config(priv_dir, Config),
{Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
- {user_dir, UserDir},
+ {user_dir, UserDir},
{failfun, fun ssh_test_lib:failfun/2},
+ {user_passwords,
+ [{"simon", "says"}]},
{rekey_limit, 0}]),
+
ConnectionRef =
ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true},
{user_dir, UserDir},
+ {user, "simon"},
+ {password, "says"},
{user_interaction, false},
{rekey_limit, 0}]),
receive
- after 200000 ->
+ after ?REKEY_DATA_TMO ->
%%By this time rekeying would have been done
ssh:close(ConnectionRef),
ssh:stop_daemon(Pid)
end.
%%--------------------------------------------------------------------
+rekey_limit() ->
+ [{doc, "Test rekeying by data volume"}].
+rekey_limit(Config) ->
+ SystemDir = ?config(data_dir, Config),
+ UserDir = ?config(priv_dir, Config),
+ DataFile = filename:join(UserDir, "rekey.data"),
+
+ {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user_passwords,
+ [{"simon", "says"}]}]),
+ {ok, SftpPid, ConnectionRef} =
+ ssh_sftp:start_channel(Host, Port, [{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user, "simon"},
+ {password, "says"},
+ {rekey_limit, 2500},
+ {user_interaction, false},
+ {silently_accept_hosts, true}]),
+
+ Kex1 = get_kex_init(ConnectionRef),
+
+ ct:sleep(?REKEY_DATA_TMO),
+ Kex1 = get_kex_init(ConnectionRef),
+
+ Data = lists:duplicate(9000,1),
+ ok = ssh_sftp:write_file(SftpPid, DataFile, Data),
+
+ ct:sleep(?REKEY_DATA_TMO),
+ Kex2 = get_kex_init(ConnectionRef),
+
+ false = (Kex2 == Kex1),
+
+ ct:sleep(?REKEY_DATA_TMO),
+ Kex2 = get_kex_init(ConnectionRef),
+
+ ok = ssh_sftp:write_file(SftpPid, DataFile, "hi\n"),
+
+ ct:sleep(?REKEY_DATA_TMO),
+ Kex2 = get_kex_init(ConnectionRef),
+
+ false = (Kex2 == Kex1),
+
+ ct:sleep(?REKEY_DATA_TMO),
+ Kex2 = get_kex_init(ConnectionRef),
+
+
+ ssh_sftp:stop_channel(SftpPid),
+ ssh:close(ConnectionRef),
+ ssh:stop_daemon(Pid).
+
+%%--------------------------------------------------------------------
+renegotiate1() ->
+ [{doc, "Test rekeying with simulataneous send request"}].
+renegotiate1(Config) ->
+ SystemDir = ?config(data_dir, Config),
+ UserDir = ?config(priv_dir, Config),
+ DataFile = filename:join(UserDir, "renegotiate1.data"),
+
+ {Pid, Host, DPort} = ssh_test_lib:daemon([{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user_passwords,
+ [{"simon", "says"}]}]),
+ RPort = ssh_test_lib:inet_port(),
+
+ {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort),
+
+ {ok, SftpPid, ConnectionRef} =
+ ssh_sftp:start_channel(Host, RPort, [{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user, "simon"},
+ {password, "says"},
+ {user_interaction, false},
+ {silently_accept_hosts, true}]),
+
+ Kex1 = get_kex_init(ConnectionRef),
+
+ {ok, Handle} = ssh_sftp:open(SftpPid, DataFile, [write]),
+
+ ok = ssh_sftp:write(SftpPid, Handle, "hi\n"),
+
+ ssh_relay:hold(RelayPid, rx, 20, 1000),
+ ssh_connection_handler:renegotiate(ConnectionRef),
+ spawn(fun() -> ok=ssh_sftp:write(SftpPid, Handle, "another hi\n") end),
+
+ ct:sleep(2000),
+
+ Kex2 = get_kex_init(ConnectionRef),
+
+ false = (Kex2 == Kex1),
+
+ ssh_relay:stop(RelayPid),
+ ssh_sftp:stop_channel(SftpPid),
+ ssh:close(ConnectionRef),
+ ssh:stop_daemon(Pid).
+
+%%--------------------------------------------------------------------
+renegotiate2() ->
+ [{doc, "Test rekeying with inflight messages from peer"}].
+renegotiate2(Config) ->
+ SystemDir = ?config(data_dir, Config),
+ UserDir = ?config(priv_dir, Config),
+ DataFile = filename:join(UserDir, "renegotiate1.data"),
+
+ {Pid, Host, DPort} = ssh_test_lib:daemon([{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user_passwords,
+ [{"simon", "says"}]}]),
+ RPort = ssh_test_lib:inet_port(),
+
+ {ok,RelayPid} = ssh_relay:start_link({0,0,0,0}, RPort, Host, DPort),
+
+ {ok, SftpPid, ConnectionRef} =
+ ssh_sftp:start_channel(Host, RPort, [{system_dir, SystemDir},
+ {user_dir, UserDir},
+ {user, "simon"},
+ {password, "says"},
+ {user_interaction, false},
+ {silently_accept_hosts, true}]),
+
+ Kex1 = get_kex_init(ConnectionRef),
+
+ {ok, Handle} = ssh_sftp:open(SftpPid, DataFile, [write]),
+
+ ok = ssh_sftp:write(SftpPid, Handle, "hi\n"),
+
+ ssh_relay:hold(RelayPid, rx, 20, infinity),
+ spawn(fun() -> ok=ssh_sftp:write(SftpPid, Handle, "another hi\n") end),
+ %% need a small pause here to ensure ssh_sftp:write is executed
+ ct:sleep(10),
+ ssh_connection_handler:renegotiate(ConnectionRef),
+ ssh_relay:release(RelayPid, rx),
+
+ ct:sleep(2000),
+
+ Kex2 = get_kex_init(ConnectionRef),
+
+ false = (Kex2 == Kex1),
+
+ ssh_relay:stop(RelayPid),
+ ssh_sftp:stop_channel(SftpPid),
+ ssh:close(ConnectionRef),
+ ssh:stop_daemon(Pid).
+
+%%--------------------------------------------------------------------
shell() ->
[{doc, "Test that ssh:shell/2 works"}].
shell(Config) when is_list(Config) ->
@@ -1300,3 +1452,18 @@ fake_daemon(_Config) ->
{sockname,Server,ServerHost,ServerPort} -> {Server, ServerHost, ServerPort}
end.
+%% get_kex_init - helper function to get key_exchange_init_msg
+get_kex_init(Conn) ->
+ %% First, validate the key exchange is complete (StateName == connected)
+ {connected,S} = sys:get_state(Conn),
+ %% Next, walk through the elements of the #state record looking
+ %% for the #ssh_msg_kexinit record. This method is robust against
+ %% changes to either record. The KEXINIT message contains a cookie
+ %% unique to each invocation of the key exchange procedure (RFC4253)
+ SL = tuple_to_list(S),
+ case lists:keyfind(ssh_msg_kexinit, 1, SL) of
+ false ->
+ throw(not_found);
+ KexInit ->
+ KexInit
+ end.
diff --git a/lib/ssh/test/ssh_relay.erl b/lib/ssh/test/ssh_relay.erl
new file mode 100644
index 0000000000..a4f2bad2e2
--- /dev/null
+++ b/lib/ssh/test/ssh_relay.erl
@@ -0,0 +1,407 @@
+%%%-------------------------------------------------------------------
+%%% @author Simon Cornish <[email protected]>
+%%% @copyright (C) 2015, Simon Cornish
+%%% @doc
+%%% Provide manipulatable TCP-level relaying for testing SSH
+%%% @end
+%%% Created : 7 May 2015 by Simon Cornish <[email protected]>
+%%%-------------------------------------------------------------------
+-module(ssh_relay).
+
+-behaviour(gen_server).
+
+%% API
+-export([start_link/4]).
+-export([stop/1]).
+-export([hold/4, release/2, release_next/3]).
+
+%% gen_server callbacks
+-export([init/1, handle_call/3, handle_cast/2, handle_info/2,
+ terminate/2, code_change/3]).
+
+-record(hold, {
+ port,
+ n,
+ tmo,
+ tref,
+ q = []
+ }).
+
+-record(state, {
+ local_addr,
+ local_port,
+ peer_addr,
+ peer_port,
+ lpid,
+ local,
+ peer,
+ tx_hold,
+ rx_hold
+ }).
+
+-define(ACCEPT_TMO, 200).
+%%%===================================================================
+%%% API
+%%%===================================================================
+%%--------------------------------------------------------------------
+%% @doc
+%% Hold N (or 'all') messages in given direction.
+%% Messages will be released after the N+1th message or
+%% Tmo ms or 'infinity'
+%%
+%% Dir is 'tx' for direction local -> peer
+%% and 'rx' for direction peer -> local
+%%
+%% An Error, ealready, is returned if there is already a hold
+%% in the given direction
+%%
+%% @spec hold(Srv, Dir, N, Tmo) -> ok | {error, Error}
+%% @end
+%%--------------------------------------------------------------------
+hold(Srv, Dir, N, Tmo) ->
+ gen_server:call(Srv, {hold, Dir, N, Tmo}).
+
+%%--------------------------------------------------------------------
+%% @doc
+%% Release all held messages in given direction.
+%%
+%% An Error, enoent, is returned if there is no hold
+%% in the given direction
+%%
+%% @spec release(Srv, Dir) -> ok | {error, Error}
+%% @end
+%%--------------------------------------------------------------------
+release(Srv, Dir) ->
+ gen_server:call(Srv, {release, Dir}).
+
+%%--------------------------------------------------------------------
+%% @doc
+%% Release all held messages in given direction after the
+%% next message in the trigger direction
+%%
+%% An Error, enoent, is returned if there is no hold
+%% in the given direction
+%%
+%% @spec release_next(Srv, Dir, TriggerDir) -> ok | {error, Error}
+%% @end
+%%--------------------------------------------------------------------
+release_next(Srv, Dir, TriggerDir) ->
+ gen_server:call(Srv, {release_next, Dir, TriggerDir}).
+
+%%--------------------------------------------------------------------
+%% @doc
+%% Starts the server
+%%
+%% @spec start_link() -> {ok, Pid} | ignore | {error, Error}
+%% @end
+%%--------------------------------------------------------------------
+start_link(ListenAddr, ListenPort, PeerAddr, PeerPort) ->
+ gen_server:start_link(?MODULE, [ListenAddr, ListenPort, PeerAddr, PeerPort], []).
+
+stop(Srv) ->
+ unlink(Srv),
+ Srv ! stop.
+
+%%%===================================================================
+%%% gen_server callbacks
+%%%===================================================================
+
+%%--------------------------------------------------------------------
+%% @private
+%% @doc
+%% Initializes the server
+%%
+%% @spec init(Args) -> {ok, State} |
+%% {ok, State, Timeout} |
+%% ignore |
+%% {stop, Reason}
+%% @end
+%%--------------------------------------------------------------------
+init([ListenAddr, ListenPort, PeerAddr, PeerPort | Options]) ->
+ IfAddr = case ListenAddr of
+ {0,0,0,0} ->
+ [];
+ _ ->
+ [{ifaddr, ListenAddr}]
+ end,
+ case gen_tcp:listen(ListenPort, [{reuseaddr, true}, {backlog, 1}, {active, false}, binary | IfAddr]) of
+ {ok, LSock} ->
+ Parent = self(),
+ {LPid, _LMod} = spawn_monitor(fun() -> listen(Parent, LSock) end),
+ S = #state{local_addr = ListenAddr,
+ local_port = ListenPort,
+ lpid = LPid,
+ peer_addr = PeerAddr,
+ peer_port = PeerPort
+ },
+ {ok, S};
+ Error ->
+ {stop, Error}
+ end.
+
+%%--------------------------------------------------------------------
+%% @private
+%% @doc
+%% Handling call messages
+%%
+%% @spec handle_call(Request, From, State) ->
+%% {reply, Reply, State} |
+%% {reply, Reply, State, Timeout} |
+%% {noreply, State} |
+%% {noreply, State, Timeout} |
+%% {stop, Reason, Reply, State} |
+%% {stop, Reason, State}
+%% @end
+%%--------------------------------------------------------------------
+handle_call({hold, Dir, N, Tmo}, _From, State) ->
+ case Dir of
+ tx ->
+ do_hold(#state.tx_hold, State#state.peer, N, Tmo, State);
+ rx ->
+ do_hold(#state.rx_hold, State#state.local, N, Tmo, State);
+ _ ->
+ {reply, {error, einval}, State}
+ end;
+handle_call({release, Dir}, _From, State) ->
+ case Dir of
+ tx ->
+ do_release(#state.tx_hold, State);
+ rx ->
+ do_release(#state.rx_hold, State);
+ _ ->
+ {reply, {error, einval}, State}
+ end;
+handle_call({release_next, _Dir, _TriggerDir}, _From, State) ->
+ {reply, {error, nyi}, State};
+
+handle_call(Request, _From, State) ->
+ Reply = {unhandled, Request},
+ {reply, Reply, State}.
+
+%%--------------------------------------------------------------------
+%% @private
+%% @doc
+%% Handling cast messages
+%%
+%% @spec handle_cast(Msg, State) -> {noreply, State} |
+%% {noreply, State, Timeout} |
+%% {stop, Reason, State}
+%% @end
+%%--------------------------------------------------------------------
+handle_cast(_Msg, State) ->
+ {noreply, State}.
+
+%%--------------------------------------------------------------------
+%% @private
+%% @doc
+%% Handling all non call/cast messages
+%%
+%% @spec handle_info(Info, State) -> {noreply, State} |
+%% {noreply, State, Timeout} |
+%% {stop, Reason, State}
+%% @end
+%%--------------------------------------------------------------------
+handle_info({tcp, Local, Data}, S) when S#state.local == Local ->
+ S1 = do_local(Data, S),
+ {noreply, S1};
+
+handle_info({tcp_error, Local, Error}, S) when S#state.local == Local ->
+ S1 = do_local({error, Error}, S),
+ {noreply, S1};
+
+handle_info({tcp_closed, Local}, S) when S#state.local == Local ->
+ S1 = do_local(closed, S),
+ {noreply, S1};
+
+handle_info({tcp, Peer, Data}, S) when S#state.peer == Peer ->
+ S1 = do_peer(Data, S),
+ {noreply, S1};
+
+handle_info({tcp_error, Peer, Error}, S) when S#state.peer == Peer ->
+ S1 = do_peer({error, Error}, S),
+ {noreply, S1};
+
+handle_info({tcp_closed, Peer}, S) when S#state.peer == Peer ->
+ S1 = do_peer(closed, S),
+ {noreply, S1};
+
+handle_info({accept, Local}, S) ->
+ S1 = do_accept(Local, S),
+ {noreply, S1};
+
+handle_info({activate, Local}, State) ->
+ inet:setopts(Local, [{active, true}]),
+ {noreply, State};
+
+handle_info({release, Pos}, S) ->
+ {reply, _, S1} = do_release(Pos,S),
+ {noreply, S1};
+
+handle_info(stop, State) ->
+ {stop, normal, State};
+
+handle_info({'DOWN', _Ref, _process, LPid, Reason}, S) when S#state.lpid == LPid ->
+ io:format("Acceptor has finished: ~p~n", [Reason]),
+ {noreply, S};
+
+handle_info(_Info, State) ->
+ io:format("Unhandled info: ~p~n", [_Info]),
+ {noreply, State}.
+
+%%--------------------------------------------------------------------
+%% @private
+%% @doc
+%% This function is called by a gen_server when it is about to
+%% terminate. It should be the opposite of Module:init/1 and do any
+%% necessary cleaning up. When it returns, the gen_server terminates
+%% with Reason. The return value is ignored.
+%%
+%% @spec terminate(Reason, State) -> void()
+%% @end
+%%--------------------------------------------------------------------
+terminate(_Reason, _State) ->
+ ok.
+
+%%--------------------------------------------------------------------
+%% @private
+%% @doc
+%% Convert process state when code is changed
+%%
+%% @spec code_change(OldVsn, State, Extra) -> {ok, NewState}
+%% @end
+%%--------------------------------------------------------------------
+code_change(_OldVsn, State, _Extra) ->
+ {ok, State}.
+
+%%%===================================================================
+%%% Internal functions
+%%%===================================================================
+do_hold(Pos, _Port, _N, _Tmo, S) when element(Pos, S) /= undefined ->
+ {reply, {error, ealready}, S};
+do_hold(Pos, Port, N, Tmo, S) ->
+ TRef = if is_integer(Tmo) andalso Tmo > 0 ->
+ erlang:send_after(Tmo, self(), {release, Pos});
+ true ->
+ undefined
+ end,
+ Hold = #hold{port = Port, n = N, tmo = Tmo, tref = TRef},
+ {reply, ok, setelement(Pos, S, Hold)}.
+
+do_release(HPos, S) when element(HPos, S) == undefined ->
+ {reply, {error, enoent}, S};
+do_release(HPos, S) ->
+ #hold{port = Port, tref = TRef, q = Q} = element(HPos, S),
+ lists:foreach(fun(M) -> gen_tcp:send(Port, M), erlang:yield() end, Q),
+ catch erlang:cancel_timer(TRef),
+ receive
+ {release, HPos} -> ok
+ after 0 ->
+ ok
+ end,
+ {reply, ok, setelement(HPos, S, undefined)}.
+
+listen(Parent, LSock) ->
+ monitor(process, Parent),
+ do_listen(Parent, LSock).
+
+do_listen(Parent, LSock) ->
+ %% So annoying there is no select-like sematic for this
+ case gen_tcp:accept(LSock, ?ACCEPT_TMO) of
+ {ok, Sock} ->
+ Parent ! {accept, Sock},
+ gen_tcp:controlling_process(Sock, Parent),
+ Parent ! {activate, Sock},
+ do_flush(Parent, Sock),
+ gen_tcp:close(LSock);
+ {error, timeout} ->
+ receive
+ DOWN when element(1, DOWN) == 'DOWN' ->
+ ok;
+ stop ->
+ ok
+ after 1 ->
+ do_listen(Parent, LSock)
+ end;
+ Error ->
+ gen_tcp:close(LSock),
+ exit({accept,Error})
+ end.
+
+do_flush(Parent, Sock) ->
+ receive
+ {Tcp, Sock, _} = Msg when Tcp == tcp; Tcp == tcp_error ->
+ Parent ! Msg,
+ do_flush(Parent, Sock);
+ {tcp_closed, Sock} = Msg ->
+ Parent ! Msg,
+ do_flush(Parent, Sock)
+ after 1 ->
+ ok
+ end.
+
+do_accept(Local, S) ->
+ case gen_tcp:connect(S#state.peer_addr, S#state.peer_port, [{active, true}, binary]) of
+ {ok, Peer} ->
+ S#state{local = Local, peer = Peer};
+ Error ->
+ exit({connect, Error})
+ end.
+
+do_local(Data, S) when is_binary(Data) ->
+ TxH = S#state.tx_hold,
+ if TxH == undefined ->
+ gen_tcp:send(S#state.peer, Data),
+ S;
+ TxH#hold.n == 0 ->
+ lists:foreach(fun(M) -> gen_tcp:send(S#state.peer, M) end, TxH#hold.q),
+ gen_tcp:send(S#state.peer, Data),
+ catch erlang:cancel_timer(TxH#hold.tref),
+ TxP = #state.tx_hold,
+ receive
+ {release, TxP} ->
+ ok
+ after 0 ->
+ ok
+ end,
+ S#state{tx_hold = undefined};
+ true ->
+ Q = TxH#hold.q ++ [Data],
+ N = if is_integer(TxH#hold.n) ->
+ TxH#hold.n -1;
+ true ->
+ TxH#hold.n
+ end,
+ S#state{tx_hold = TxH#hold{q = Q, n = N}}
+ end;
+do_local(Error, _S) ->
+ exit({local, Error}).
+
+do_peer(Data, S) when is_binary(Data) ->
+ RxH = S#state.rx_hold,
+ if RxH == undefined ->
+ gen_tcp:send(S#state.local, Data),
+ S;
+ RxH#hold.n == 0 ->
+ lists:foreach(fun(M) -> gen_tcp:send(S#state.local, M) end, RxH#hold.q),
+ gen_tcp:send(S#state.local, Data),
+ catch erlang:cancel_timer(RxH#hold.tref),
+ RxP = #state.rx_hold,
+ receive
+ {release, RxP} ->
+ ok
+ after 0 ->
+ ok
+ end,
+ S#state{rx_hold = undefined};
+ true ->
+ Q = RxH#hold.q ++ [Data],
+ N = if is_integer(RxH#hold.n) ->
+ RxH#hold.n -1;
+ true ->
+ RxH#hold.n
+ end,
+ S#state{rx_hold = RxH#hold{q = Q, n = N}}
+ end;
+do_peer(Error, _S) ->
+ exit({peer, Error}).
+
diff --git a/lib/ssl/test/ssl_alpn_handshake_SUITE.erl b/lib/ssl/test/ssl_alpn_handshake_SUITE.erl
index ccd70fa605..ae76f5849e 100644
--- a/lib/ssl/test/ssl_alpn_handshake_SUITE.erl
+++ b/lib/ssl/test/ssl_alpn_handshake_SUITE.erl
@@ -384,7 +384,7 @@ ssl_receive_and_assert_alpn(Socket, Protocol, Data) ->
ssl_send(Socket, Data) ->
ct:log("Connection info: ~p~n",
- [ssl:connection_info(Socket)]),
+ [ssl:connection_information(Socket)]),
ssl:send(Socket, Data).
ssl_receive(Socket, Data) ->
@@ -392,7 +392,7 @@ ssl_receive(Socket, Data) ->
ssl_receive(Socket, Data, Buffer) ->
ct:log("Connection info: ~p~n",
- [ssl:connection_info(Socket)]),
+ [ssl:connection_information(Socket)]),
receive
{ssl, Socket, MoreData} ->
ct:log("Received ~p~n",[MoreData]),
@@ -411,4 +411,4 @@ ssl_receive(Socket, Data, Buffer) ->
end.
connection_info_result(Socket) ->
- ssl:connection_info(Socket).
+ ssl:connection_information(Socket).
diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl
index 3495b978b7..e1a36dbbd4 100644
--- a/lib/ssl/test/ssl_basic_SUITE.erl
+++ b/lib/ssl/test/ssl_basic_SUITE.erl
@@ -384,7 +384,7 @@ new_options_in_accept(Config) when is_list(Config) ->
%%--------------------------------------------------------------------
connection_info() ->
- [{doc,"Test the API function ssl:connection_info/1"}].
+ [{doc,"Test the API function ssl:connection_information/1"}].
connection_info(Config) when is_list(Config) ->
ClientOpts = ?config(client_opts, Config),
ServerOpts = ?config(server_opts, Config),
@@ -2831,7 +2831,7 @@ listen_socket(Config) ->
{error, enotconn} = ssl:send(ListenSocket, <<"data">>),
{error, enotconn} = ssl:recv(ListenSocket, 0),
- {error, enotconn} = ssl:connection_info(ListenSocket),
+ {error, enotconn} = ssl:connection_information(ListenSocket),
{error, enotconn} = ssl:peername(ListenSocket),
{error, enotconn} = ssl:peercert(ListenSocket),
{error, enotconn} = ssl:session_info(ListenSocket),
@@ -3836,10 +3836,10 @@ cipher(CipherSuite, Version, Config, ClientOpts, ServerOpts) ->
end.
connection_info_result(Socket) ->
- ssl:connection_info(Socket).
-
+ {ok, Info} = ssl:connection_information(Socket, [protocol, cipher_suite]),
+ {ok, {proplists:get_value(protocol, Info), proplists:get_value(cipher_suite, Info)}}.
version_info_result(Socket) ->
- {ok, {Version, _}} = ssl:connection_info(Socket),
+ {ok, [{version, Version}]} = ssl:connection_information(Socket, [version]),
{ok, Version}.
connect_dist_s(S) ->
diff --git a/lib/ssl/test/ssl_npn_handshake_SUITE.erl b/lib/ssl/test/ssl_npn_handshake_SUITE.erl
index 326f907e66..8e95679306 100644
--- a/lib/ssl/test/ssl_npn_handshake_SUITE.erl
+++ b/lib/ssl/test/ssl_npn_handshake_SUITE.erl
@@ -332,7 +332,7 @@ ssl_receive_and_assert_npn(Socket, Protocol, Data) ->
ssl_send(Socket, Data) ->
ct:log("Connection info: ~p~n",
- [ssl:connection_info(Socket)]),
+ [ssl:connection_information(Socket)]),
ssl:send(Socket, Data).
ssl_receive(Socket, Data) ->
@@ -340,7 +340,7 @@ ssl_receive(Socket, Data) ->
ssl_receive(Socket, Data, Buffer) ->
ct:log("Connection info: ~p~n",
- [ssl:connection_info(Socket)]),
+ [ssl:connection_information(Socket)]),
receive
{ssl, Socket, MoreData} ->
ct:log("Received ~p~n",[MoreData]),
@@ -360,4 +360,4 @@ ssl_receive(Socket, Data, Buffer) ->
connection_info_result(Socket) ->
- ssl:connection_info(Socket).
+ ssl:connection_information(Socket).
diff --git a/lib/ssl/test/ssl_sni_SUITE.erl b/lib/ssl/test/ssl_sni_SUITE.erl
index 46cd644e4d..b059ff991b 100644
--- a/lib/ssl/test/ssl_sni_SUITE.erl
+++ b/lib/ssl/test/ssl_sni_SUITE.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2008-2015. All Rights Reserved.
+%% Copyright Ericsson AB 2015-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
@@ -16,7 +16,6 @@
%%
%% %CopyrightEnd%
%%
-
%%
-module(ssl_sni_SUITE).
@@ -31,7 +30,12 @@
%%--------------------------------------------------------------------
suite() -> [{ct_hooks,[ts_install_cth]}].
-all() -> [no_sni_header, sni_match, sni_no_match] ++ [no_sni_header_fun, sni_match_fun, sni_no_match_fun].
+all() -> [no_sni_header,
+ sni_match,
+ sni_no_match,
+ no_sni_header_fun,
+ sni_match_fun,
+ sni_no_match_fun].
init_per_suite(Config0) ->
catch crypto:stop(),
@@ -39,11 +43,11 @@ init_per_suite(Config0) ->
ok ->
ssl:start(),
Result =
- (catch make_certs:all(?config(data_dir, Config0),
- ?config(priv_dir, Config0))),
+ (catch make_certs:all(?config(data_dir, Config0),
+ ?config(priv_dir, Config0))),
ct:log("Make certs ~p~n", [Result]),
ssl_test_lib:cert_options(Config0)
- catch _:_ ->
+ catch _:_ ->
{skip, "Crypto did not start"}
end.
@@ -76,8 +80,6 @@ sni_no_match_fun(Config) ->
%%--------------------------------------------------------------------
%% Internal Functions ------------------------------------------------
%%--------------------------------------------------------------------
-
-
ssl_recv(SSLSocket, Expect) ->
ssl_recv(SSLSocket, "", Expect).
@@ -93,20 +95,21 @@ ssl_recv(SSLSocket, CurrentData, ExpectedData) ->
end;
Other ->
ct:fail({unexpected_message, Other})
- after 4000 ->
+ after 4000 ->
ct:fail({timeout, CurrentData, ExpectedData})
end.
-
-
send_and_hostname(SSLSocket) ->
ssl:send(SSLSocket, "OK"),
{ok, [{sni_hostname, Hostname}]} = ssl:connection_information(SSLSocket, [sni_hostname]),
Hostname.
-rdnPart([[#'AttributeTypeAndValue'{type=Type, value=Value} | _] | _], Type) -> Value;
-rdnPart([_ | Tail], Type) -> rdnPart(Tail, Type);
-rdnPart([], _) -> unknown.
+rdnPart([[#'AttributeTypeAndValue'{type=Type, value=Value} | _] | _], Type) ->
+ Value;
+rdnPart([_ | Tail], Type) ->
+ rdnPart(Tail, Type);
+rdnPart([], _) ->
+ unknown.
rdn_to_string({utf8String, Binary}) ->
erlang:binary_to_list(Binary);
@@ -116,12 +119,15 @@ rdn_to_string({printableString, String}) ->
recv_and_certificate(SSLSocket) ->
ssl_recv(SSLSocket, "OK"),
{ok, PeerCert} = ssl:peercert(SSLSocket),
- #'OTPCertificate'{tbsCertificate = #'OTPTBSCertificate'{subject = {rdnSequence, Subject}}} = public_key:pkix_decode_cert(PeerCert, otp),
+ #'OTPCertificate'{tbsCertificate = #'OTPTBSCertificate'{subject = {rdnSequence, Subject}}}
+ = public_key:pkix_decode_cert(PeerCert, otp),
ct:log("Subject of certificate received from server: ~p", [Subject]),
rdn_to_string(rdnPart(Subject, ?'id-at-commonName')).
run_sni_fun_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) ->
- ct:log("Start running handshake for sni_fun, Config: ~p, SNIHostname: ~p, ExpectedSNIHostname: ~p, ExpectedCN: ~p", [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]),
+ ct:log("Start running handshake for sni_fun, Config: ~p, SNIHostname: ~p, "
+ "ExpectedSNIHostname: ~p, ExpectedCN: ~p",
+ [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]),
[{sni_hosts, ServerSNIConf}] = ?config(sni_server_opts, Config),
SNIFun = fun(Domain) -> proplists:get_value(Domain, ServerSNIConf, undefined) end,
ServerOptions = ?config(server_opts, Config) ++ [{sni_fun, SNIFun}],
@@ -142,11 +148,14 @@ run_sni_fun_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) ->
{host, Hostname}, {from, self()},
{mfa, {?MODULE, recv_and_certificate, []}},
{options, ClientOptions}]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN).
-
+ ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN),
+ ssl_test_lib:close(Server),
+ ssl_test_lib:close(Client).
run_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) ->
- ct:log("Start running handshake, Config: ~p, SNIHostname: ~p, ExpectedSNIHostname: ~p, ExpectedCN: ~p", [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]),
+ ct:log("Start running handshake, Config: ~p, SNIHostname: ~p, "
+ "ExpectedSNIHostname: ~p, ExpectedCN: ~p",
+ [Config, SNIHostname, ExpectedSNIHostname, ExpectedCN]),
ServerOptions = ?config(sni_server_opts, Config) ++ ?config(server_opts, Config),
ClientOptions =
case SNIHostname of
@@ -165,4 +174,6 @@ run_handshake(Config, SNIHostname, ExpectedSNIHostname, ExpectedCN) ->
{host, Hostname}, {from, self()},
{mfa, {?MODULE, recv_and_certificate, []}},
{options, ClientOptions}]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN).
+ ssl_test_lib:check_result(Server, ExpectedSNIHostname, Client, ExpectedCN),
+ ssl_test_lib:close(Server),
+ ssl_test_lib:close(Client).
diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl
index 8b98e6f16b..a3bfdf8893 100644
--- a/lib/ssl/test/ssl_test_lib.erl
+++ b/lib/ssl/test/ssl_test_lib.erl
@@ -949,7 +949,8 @@ der_to_pem(File, Entries) ->
file:write_file(File, PemBin).
cipher_result(Socket, Result) ->
- Result = ssl:connection_info(Socket),
+ {ok, Info} = ssl:connection_information(Socket),
+ Result = {ok, {proplists:get_value(protocol, Info), proplists:get_value(cipher_suite, Info)}},
ct:log("~p:~p~nSuccessfull connect: ~p~n", [?MODULE,?LINE, Result]),
%% Importante to send two packets here
%% to properly test "cipher state" handling
diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl
index 0413415e49..aca34cb6e9 100644
--- a/lib/ssl/test/ssl_to_openssl_SUITE.erl
+++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl
@@ -1243,15 +1243,16 @@ run_suites(Ciphers, Version, Config, Type) ->
ct:fail(cipher_suite_failed_see_test_case_log)
end.
-client_read_check([], _NewData) -> ok;
-client_read_check([Hd | T], NewData) ->
- case binary:match(NewData, list_to_binary(Hd)) of
+client_read_check([], _Data) ->
+ ok;
+client_read_check([Hd | T], Data) ->
+ case binary:match(Data, list_to_binary(Hd)) of
nomatch ->
nomatch;
_ ->
- client_read_check(T, NewData)
+ client_read_check(T, Data)
end.
-client_read_bulk(Port, DataExpected, DataReceived) ->
+client_check_result(Port, DataExpected, DataReceived) ->
receive
{Port, {data, TheData}} ->
Data = list_to_binary(TheData),
@@ -1261,15 +1262,14 @@ client_read_bulk(Port, DataExpected, DataReceived) ->
ok ->
ok;
_ ->
- client_read_bulk(Port, DataExpected, NewData)
- end;
- _ ->
- ct:fail("unexpected_message")
- after 4000 ->
- ct:fail("timeout")
+ client_check_result(Port, DataExpected, NewData)
+ end
+ after 3000 ->
+ ct:fail({"Time out on opensssl Client", {expected, DataExpected},
+ {got, DataReceived}})
end.
-client_read_bulk(Port, DataExpected) ->
- client_read_bulk(Port, DataExpected, <<"">>).
+client_check_result(Port, DataExpected) ->
+ client_check_result(Port, DataExpected, <<"">>).
send_and_hostname(SSLSocket) ->
ssl:send(SSLSocket, "OK"),
@@ -1292,9 +1292,12 @@ erlang_server_openssl_client_sni_test(Config, SNIHostname, ExpectedSNIHostname,
end,
ct:log("Options: ~p", [[ServerOptions, ClientCommand]]),
ClientPort = open_port({spawn, ClientCommand}, [stderr_to_stdout]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname),
+
+ %% Client check needs to be done befor server check,
+ %% or server check might consume client messages
ExpectedClientOutput = ["OK", "/CN=" ++ ExpectedCN ++ "/"],
- ok = client_read_bulk(ClientPort, ExpectedClientOutput),
+ client_check_result(ClientPort, ExpectedClientOutput),
+ ssl_test_lib:check_result(Server, ExpectedSNIHostname),
ssl_test_lib:close_port(ClientPort),
ssl_test_lib:close(Server),
ok.
@@ -1318,12 +1321,14 @@ erlang_server_openssl_client_sni_test_sni_fun(Config, SNIHostname, ExpectedSNIHo
end,
ct:log("Options: ~p", [[ServerOptions, ClientCommand]]),
ClientPort = open_port({spawn, ClientCommand}, [stderr_to_stdout]),
- ssl_test_lib:check_result(Server, ExpectedSNIHostname),
+
+ %% Client check needs to be done befor server check,
+ %% or server check might consume client messages
ExpectedClientOutput = ["OK", "/CN=" ++ ExpectedCN ++ "/"],
- ok = client_read_bulk(ClientPort, ExpectedClientOutput),
+ client_check_result(ClientPort, ExpectedClientOutput),
+ ssl_test_lib:check_result(Server, ExpectedSNIHostname),
ssl_test_lib:close_port(ClientPort),
- ssl_test_lib:close(Server),
- ok.
+ ssl_test_lib:close(Server).
cipher(CipherSuite, Version, Config, ClientOpts, ServerOpts) ->
@@ -1664,7 +1669,7 @@ erlang_ssl_receive_and_assert_negotiated_protocol(Socket, Protocol, Data) ->
erlang_ssl_receive(Socket, Data) ->
ct:log("Connection info: ~p~n",
- [ssl:connection_info(Socket)]),
+ [ssl:connection_information(Socket)]),
receive
{ssl, Socket, Data} ->
io:format("Received ~p~n",[Data]),
@@ -1683,16 +1688,16 @@ erlang_ssl_receive(Socket, Data) ->
end.
connection_info(Socket, Version) ->
- case ssl:connection_info(Socket) of
- {ok, {Version, _} = Info} ->
+ case ssl:connection_information(Socket, [version]) of
+ {ok, [{version, Version}] = Info} ->
ct:log("Connection info: ~p~n", [Info]),
ok;
- {ok, {OtherVersion, _}} ->
+ {ok, [{version, OtherVersion}]} ->
{wrong_version, OtherVersion}
end.
connection_info_result(Socket) ->
- ssl:connection_info(Socket).
+ ssl:connection_information(Socket).
delayed_send(Socket, [ErlData, OpenSslData]) ->
diff --git a/lib/stdlib/doc/src/ets.xml b/lib/stdlib/doc/src/ets.xml
index 6b9524ef63..2bfe074c3e 100644
--- a/lib/stdlib/doc/src/ets.xml
+++ b/lib/stdlib/doc/src/ets.xml
@@ -1435,7 +1435,9 @@ is_integer(X), is_integer(Y), X + Y < 4711]]></code>
<p>Whenever the <c>extended_info</c> option is used, it
results in a file not readable by versions of ets prior to
that in stdlib-1.15.1</p>
-
+ <p>The <c>sync</c> option, if set to <c>true</c>, ensures that
+ the content of the file is actually written to the disk before
+ <c>tab2file</c> returns. Default is <c>{sync, false}</c>.</p>
</desc>
</func>
<func>
diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl
index c68ec601bf..ac92004061 100644
--- a/lib/stdlib/src/erl_lint.erl
+++ b/lib/stdlib/src/erl_lint.erl
@@ -127,7 +127,6 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) ->
recdef_top=false :: boolean(), %true in record initialisation
%outside any fun or lc
xqlc= false :: boolean(), %true if qlc.hrl included
- new = false :: boolean(), %Has user-defined 'new/N'
called= [] :: [{fa(),line()}], %Called functions
usage = #usage{} :: #usage{},
specs = dict:new() %Type specifications
@@ -610,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'
@@ -642,8 +649,6 @@ forms(Forms0, St0) ->
St4 = foldl(fun form/2, pre_scan(Forms, St3), Forms),
post_traversal_check(Forms, St4).
-pre_scan([{function,_L,new,_A,_Cs} | Fs], St) ->
- pre_scan(Fs, St#lint{new=true});
pre_scan([{attribute,L,compile,C} | Fs], St) ->
case is_warn_enabled(export_all, St) andalso
member(export_all, lists:flatten([C])) of
@@ -670,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).
@@ -799,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 =:= [] ->
@@ -927,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.
@@ -1145,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);
@@ -1338,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.
@@ -2124,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!
@@ -2985,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;
@@ -3023,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) ->
@@ -3040,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],
@@ -3398,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/ets.erl b/lib/stdlib/src/ets.erl
index 1df069755d..0e2d59d0c3 100644
--- a/lib/stdlib/src/ets.erl
+++ b/lib/stdlib/src/ets.erl
@@ -739,7 +739,8 @@ do_filter(Tab, Key, F, A, Ack) ->
-record(filetab_options,
{
object_count = false :: boolean(),
- md5sum = false :: boolean()
+ md5sum = false :: boolean(),
+ sync = false :: boolean()
}).
-spec tab2file(Tab, Filename) -> 'ok' | {'error', Reason} when
@@ -754,7 +755,7 @@ tab2file(Tab, File) ->
Tab :: tab(),
Filename :: file:name(),
Options :: [Option],
- Option :: {'extended_info', [ExtInfo]},
+ Option :: {'extended_info', [ExtInfo]} | {'sync', boolean()},
ExtInfo :: 'md5sum' | 'object_count',
Reason :: term().
@@ -835,6 +836,15 @@ tab2file(Tab, File, Options) ->
List ->
LogFun(NewState1,[['$end_of_table',List]])
end,
+ case FtOptions#filetab_options.sync of
+ true ->
+ case disk_log:sync(Name) of
+ ok -> ok;
+ {error, Reason2} -> throw(Reason2)
+ end;
+ false ->
+ ok
+ end,
disk_log:close(Name)
catch
throw:TReason ->
@@ -887,23 +897,24 @@ md5terms(State, [H|T]) ->
{FinState, [B|TL]}.
parse_ft_options(Options) when is_list(Options) ->
- {Opt,Rest} = case (catch lists:keytake(extended_info,1,Options)) of
- false ->
- {[],Options};
- {value,{extended_info,L},R} when is_list(L) ->
- {L,R}
- end,
- case Rest of
- [] ->
- parse_ft_info_options(#filetab_options{}, Opt);
- Other ->
- throw({unknown_option, Other})
- end;
-parse_ft_options(Malformed) ->
+ {ok, parse_ft_options(Options, #filetab_options{}, false)}.
+
+parse_ft_options([], FtOpt, _) ->
+ FtOpt;
+parse_ft_options([{sync,true} | Rest], FtOpt, EI) ->
+ parse_ft_options(Rest, FtOpt#filetab_options{sync = true}, EI);
+parse_ft_options([{sync,false} | Rest], FtOpt, EI) ->
+ parse_ft_options(Rest, FtOpt, EI);
+parse_ft_options([{extended_info,L} | Rest], FtOpt0, false) ->
+ FtOpt1 = parse_ft_info_options(FtOpt0, L),
+ parse_ft_options(Rest, FtOpt1, true);
+parse_ft_options([Other | _], _, _) ->
+ throw({unknown_option, Other});
+parse_ft_options(Malformed, _, _) ->
throw({malformed_option, Malformed}).
parse_ft_info_options(FtOpt,[]) ->
- {ok,FtOpt};
+ FtOpt;
parse_ft_info_options(FtOpt,[object_count | T]) ->
parse_ft_info_options(FtOpt#filetab_options{object_count = true}, T);
parse_ft_info_options(FtOpt,[md5sum | T]) ->
diff --git a/lib/stdlib/src/stdlib.app.src b/lib/stdlib/src/stdlib.app.src
index a27a35dca2..c33130cf8c 100644
--- a/lib/stdlib/src/stdlib.app.src
+++ b/lib/stdlib/src/stdlib.app.src
@@ -104,7 +104,7 @@
dets]},
{applications, [kernel]},
{env, []},
- {runtime_dependencies, ["sasl-2.4","kernel-3.0.2","erts-7.0","crypto-3.3",
+ {runtime_dependencies, ["sasl-2.4","kernel-4.0","erts-7.0","crypto-3.3",
"compiler-5.0"]}
]}.
diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl
index 1b53d52d6a..fff6b11a38 100644
--- a/lib/stdlib/test/ets_SUITE.erl
+++ b/lib/stdlib/test/ets_SUITE.erl
@@ -4078,12 +4078,22 @@ tab2file(doc) -> ["Check the ets:tab2file function on an empty "
"ets table."];
tab2file(suite) -> [];
tab2file(Config) when is_list(Config) ->
+ ?line FName = filename:join([?config(priv_dir, Config),"tab2file_case"]),
+ tab2file_do(FName, []),
+ tab2file_do(FName, [{sync,true}]),
+ tab2file_do(FName, [{sync,false}]),
+ {'EXIT',{{badmatch,{error,_}},_}} = (catch tab2file_do(FName, [{sync,yes}])),
+ {'EXIT',{{badmatch,{error,_}},_}} = (catch tab2file_do(FName, [sync])),
+ ok.
+
+tab2file_do(FName, Opts) ->
%% Write an empty ets table to a file, read back and check properties.
?line Tab = ets_new(ets_SUITE_foo_tab, [named_table, set, private,
{keypos, 2}]),
- ?line FName = filename:join([?config(priv_dir, Config),"tab2file_case"]),
- ?line ok = ets:tab2file(Tab, FName),
- ?line true = ets:delete(Tab),
+ catch file:delete(FName),
+ Res = ets:tab2file(Tab, FName, Opts),
+ true = ets:delete(Tab),
+ ok = Res,
%
?line EtsMem = etsmem(),
?line {ok, Tab2} = ets:file2tab(FName),
@@ -4093,6 +4103,7 @@ tab2file(Config) when is_list(Config) ->
?line set = ets:info(Tab2, type),
?line true = ets:delete(Tab2),
?line verify_etsmem(EtsMem).
+
tab2file2(doc) -> ["Check the ets:tab2file function on a ",
"filled set/bag type ets table."];
diff --git a/lib/stdlib/test/maps_SUITE.erl b/lib/stdlib/test/maps_SUITE.erl
index 21e146ae3d..f8f241d834 100644
--- a/lib/stdlib/test/maps_SUITE.erl
+++ b/lib/stdlib/test/maps_SUITE.erl
@@ -38,8 +38,11 @@
t_fold_3/1,t_map_2/1,t_size_1/1,
t_with_2/1,t_without_2/1]).
--define(badmap(V,F,Args), {'EXIT', {{badmap,V}, [{maps,F,Args,_}|_]}}).
--define(badarg(F,Args), {'EXIT', {badarg, [{maps,F,Args,_}|_]}}).
+%-define(badmap(V,F,Args), {'EXIT', {{badmap,V}, [{maps,F,Args,_}|_]}}).
+%-define(badarg(F,Args), {'EXIT', {badarg, [{maps,F,Args,_}|_]}}).
+% silly broken hipe
+-define(badmap(V,F,_Args), {'EXIT', {{badmap,V}, [{maps,F,_,_}|_]}}).
+-define(badarg(F,_Args), {'EXIT', {badarg, [{maps,F,_,_}|_]}}).
suite() ->
[{ct_hooks, [ts_install_cth]}].
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/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/wx/c_src/wxe_driver.c b/lib/wx/c_src/wxe_driver.c
index ea52737fa2..ec1ba7f566 100644
--- a/lib/wx/c_src/wxe_driver.c
+++ b/lib/wx/c_src/wxe_driver.c
@@ -146,7 +146,12 @@ wxe_driver_stop(ErlDrvData handle)
if(sd->port_handle != WXE_DRV_PORT_HANDLE) {
// fprintf(stderr, "%s:%d: STOP \r\n", __FILE__,__LINE__);
meta_command(DELETE_PORT,sd);
- free(handle);
+ } else {
+ // fprintf(stderr, "%s:%d: STOP \r\n", __FILE__,__LINE__);
+ stop_native_gui(wxe_master);
+ unload_native_gui();
+ free(wxe_master);
+ wxe_master = NULL;
}
}
@@ -154,10 +159,6 @@ static void
wxe_driver_unload(void)
{
// fprintf(stderr, "%s:%d: UNLOAD \r\n", __FILE__,__LINE__);
- stop_native_gui(wxe_master);
- unload_native_gui();
- free(wxe_master);
- wxe_master = NULL;
}
static ErlDrvSSizeT
diff --git a/lib/wx/c_src/wxe_impl.cpp b/lib/wx/c_src/wxe_impl.cpp
index ef648e008c..2fd5f0c52c 100644
--- a/lib/wx/c_src/wxe_impl.cpp
+++ b/lib/wx/c_src/wxe_impl.cpp
@@ -89,7 +89,7 @@ void push_command(int op,char * buf,int len, wxe_data *sd)
}
void meta_command(int what, wxe_data *sd) {
- if(what == PING_PORT) {
+ if(what == PING_PORT && wxe_status == WXE_INITIATED) {
erl_drv_mutex_lock(wxe_batch_locker_m);
if(wxe_batch_caller > 0) {
wxe_queue->Add(WXE_DEBUG_PING, NULL, 0, sd);
@@ -98,9 +98,12 @@ void meta_command(int what, wxe_data *sd) {
wxWakeUpIdle();
erl_drv_mutex_unlock(wxe_batch_locker_m);
} else {
- if(sd) {
+ if(sd && wxe_status == WXE_INITIATED) {
wxeMetaCommand Cmd(sd, what);
wxTheApp->AddPendingEvent(Cmd);
+ if(what == DELETE_PORT) {
+ free(sd);
+ }
}
}
}
@@ -169,6 +172,7 @@ void WxeApp::MacOpenFile(const wxString &filename) {
#endif
void WxeApp::shutdown(wxeMetaCommand& Ecmd) {
+ wxe_status = WXE_EXITING;
ExitMainLoop();
delete wxe_queue;
delete wxe_queue_cb_saved;
@@ -200,6 +204,10 @@ void handle_event_callback(ErlDrvPort port, ErlDrvTermData process)
{
WxeApp * app = (WxeApp *) wxTheApp;
ErlDrvMonitor monitor;
+
+ if(wxe_status != WXE_INITIATED)
+ return;
+
// Is thread safe if pdl have been incremented
if(driver_monitor_process(port, process, &monitor) == 0) {
// Should we be able to handle commands when recursing? probably
@@ -217,6 +225,8 @@ void handle_event_callback(ErlDrvPort port, ErlDrvTermData process)
void WxeApp::dispatch_cmds()
{
+ if(wxe_status != WXE_INITIATED)
+ return;
erl_drv_mutex_lock(wxe_batch_locker_m);
recurse_level++;
int level = dispatch(wxe_queue_cb_saved, 0, WXE_STORED);
diff --git a/lib/wx/c_src/wxe_impl.h b/lib/wx/c_src/wxe_impl.h
index a0a1c84718..b251d5f0f9 100644
--- a/lib/wx/c_src/wxe_impl.h
+++ b/lib/wx/c_src/wxe_impl.h
@@ -46,7 +46,8 @@ typedef wxString wxeLocaleC;
#define WXE_NOT_INITIATED 0
#define WXE_INITIATED 1
-#define WXE_EXITED 2
+#define WXE_EXITING 2
+#define WXE_EXITED 3
#define WXE_ERROR -1
void send_msg(const char *, const wxString *); // For debugging and error msgs
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"]}
]}.