aboutsummaryrefslogtreecommitdiffstats
path: root/lib/tools
diff options
context:
space:
mode:
Diffstat (limited to 'lib/tools')
-rw-r--r--lib/tools/doc/src/cover.xml22
-rw-r--r--lib/tools/doc/src/instrument.xml13
-rw-r--r--lib/tools/doc/src/make.xml5
-rw-r--r--lib/tools/doc/src/notes.xml89
-rw-r--r--lib/tools/emacs/erlang-test.el11
-rw-r--r--lib/tools/emacs/erlang.el562
-rw-r--r--lib/tools/emacs/erldoc.el38
-rw-r--r--lib/tools/src/cover.erl526
-rw-r--r--lib/tools/src/tools.app.src2
-rw-r--r--lib/tools/test/Makefile3
-rw-r--r--lib/tools/test/cover_SUITE.erl65
-rw-r--r--lib/tools/test/emacs_SUITE.erl33
-rw-r--r--lib/tools/test/instrument_SUITE.erl48
-rw-r--r--lib/tools/test/prof_bench_SUITE.erl126
-rw-r--r--lib/tools/test/prof_bench_SUITE_data/sofs_copy.erl2809
-rw-r--r--lib/tools/test/tools_bench.spec1
-rw-r--r--lib/tools/vsn.mk2
17 files changed, 3917 insertions, 438 deletions
diff --git a/lib/tools/doc/src/cover.xml b/lib/tools/doc/src/cover.xml
index 64c24cea2a..e9f782977d 100644
--- a/lib/tools/doc/src/cover.xml
+++ b/lib/tools/doc/src/cover.xml
@@ -128,14 +128,26 @@
</desc>
</func>
<func>
- <name since="">start(Nodes) -> {ok,StartedNodes} | {error,not_main_node}</name>
+ <name since="OTP 22.0">local_only() -> ok | {error,too_late}</name>
+ <fsummary>Only support running Cover on the local node.</fsummary>
+ <desc>
+ <p>Only support running Cover on the local node. This function
+ must be called before any modules have been compiled or any
+ nodes added. When running in this mode, modules will be Cover
+ compiled in a more efficient way, but the resulting code will
+ only work on the same node they were compiled on.</p>
+ </desc>
+ </func>
+ <func>
+ <name since="">start(Nodes) -> {ok,StartedNodes} | {error,not_main_node} | {error,local_only}</name>
<fsummary>Start Cover on remote nodes.</fsummary>
<type>
<v>Nodes = StartedNodes = [atom()]</v>
</type>
<desc>
<p>Starts a Cover server on the each of given nodes, and loads
- all cover compiled modules.</p>
+ all cover compiled modules. This call will fail if
+ <c>cover:local_only/0</c> has been called.</p>
</desc>
</func>
<func>
@@ -234,7 +246,7 @@
<c>{already_cover_compiled,no_beam_found,Module}</c> is
returned.</p>
<p><c>{error,BeamFile}</c> is returned if the compiled code
- can not be loaded on the node.</p>
+ cannot be loaded on the node.</p>
<p>If a list of <c>ModFiles</c> is given as input, a list
of <c>Result</c> will be returned. The order of the returned
list is undefined.</p>
@@ -470,7 +482,7 @@
<p>Exports the current coverage data for <c>Module</c> to the
file <c>ExportFile</c>. It is recommended to name the
<c>ExportFile</c> with the extension <c>.coverdata</c>, since
- other filenames can not be read by the web based interface to
+ other filenames cannot be read by the web based interface to
cover.</p>
<p>If <c>Module</c> is not given, data for all Cover compiled
or earlier imported modules is exported.</p>
@@ -496,7 +508,7 @@
<p>Coverage data from several export files can be imported
into one system. The coverage data is then added up when
analysing.</p>
- <p>Coverage data for a module can not be imported from the
+ <p>Coverage data for a module cannot be imported from the
same file twice unless the module is first reset or
compiled. The check is based on the filename, so you can
easily fool the system by renaming your export file.</p>
diff --git a/lib/tools/doc/src/instrument.xml b/lib/tools/doc/src/instrument.xml
index 75be22de9b..7e9cbaebb0 100644
--- a/lib/tools/doc/src/instrument.xml
+++ b/lib/tools/doc/src/instrument.xml
@@ -111,15 +111,18 @@
default, but this can be configured an a per-allocator basis with the
<seealso marker="erts:erts_alloc#M_atags"><c>+M&lt;S&gt;atags</c>
</seealso> emulator option.</p>
- <p>If tagged allocations are not enabled on any of the specified
- allocator types, the call will fail with
- <c>{error, not_enabled}</c>.</p>
+ <p>If the specified allocator types are not enabled, the call will fail
+ with <c>{error, not_enabled}</c>.</p>
<p>The following options can be used:</p>
<taglist>
<tag><c>allocator_types</c></tag>
<item>
- <p>The allocator types that will be searched. Defaults to all
- <c>alloc_util</c> allocators.</p>
+ <p>The allocator types that will be searched. Note that blocks can
+ move freely between allocator types, so restricting the search to
+ certain allocators may return unexpected types (e.g. process
+ heaps when searching binary_alloc), or hide blocks that were
+ migrated out.</p>
+ <p>Defaults to all <c>alloc_util</c> allocators.</p>
</item>
<tag><c>scheduler_ids</c></tag>
<item>
diff --git a/lib/tools/doc/src/make.xml b/lib/tools/doc/src/make.xml
index af2404707f..322d77323f 100644
--- a/lib/tools/doc/src/make.xml
+++ b/lib/tools/doc/src/make.xml
@@ -145,5 +145,10 @@ Modules.
{'*',[debug_info]}. </code>
<p></p>
</section>
+
+ <section>
+ <title>See Also</title>
+ <p><seealso marker="compiler:compile"><c>compile(3)</c></seealso></p>
+ </section>
</erlref>
diff --git a/lib/tools/doc/src/notes.xml b/lib/tools/doc/src/notes.xml
index 28f8346a19..09ae5ef04a 100644
--- a/lib/tools/doc/src/notes.xml
+++ b/lib/tools/doc/src/notes.xml
@@ -31,6 +31,64 @@
</header>
<p>This document describes the changes made to the Tools application.</p>
+<section><title>Tools 3.2</title>
+
+ <section><title>Fixed Bugs and Malfunctions</title>
+ <list>
+ <item>
+ <p>
+ Add <c>cprof</c> and <c>tags</c> modules to .app file so
+ that they are included in releases.</p>
+ <p>
+ Own Id: OTP-15534 Aux Id: PR-2078 </p>
+ </item>
+ <item>
+ <p>
+ Improved documentation parsing in emacs erldoc
+ functionality.</p>
+ <p>
+ Own Id: OTP-15699 Aux Id: PR-2184 </p>
+ </item>
+ </list>
+ </section>
+
+
+ <section><title>Improvements and New Features</title>
+ <list>
+ <item>
+ <p>The <c>cover</c> tool now uses the <c>counters</c>
+ module instead of <c>ets</c> for updating the counters
+ for how many times a line has been executed. By default,
+ Cover will work with distributed nodes, but a new
+ function <c>cover:local_only/0</c> allows running the
+ Cover in a restricted but faster local-only mode.</p>
+ <p>The increase in speed will vary depending on the type
+ of code being cover-compiled, but as an example, the
+ compiler test suite runs more than twice as fast with the
+ new Cover.</p>
+ <p>
+ Own Id: OTP-15575</p>
+ </item>
+ </list>
+ </section>
+
+</section>
+
+<section><title>Tools 3.1.0.1</title>
+
+ <section><title>Fixed Bugs and Malfunctions</title>
+ <list>
+ <item>
+ <p><c>cover</c> would fail to start if two processes
+ tried to start it at the exact same time.</p>
+ <p>
+ Own Id: OTP-15813 Aux Id: ERL-943 </p>
+ </item>
+ </list>
+ </section>
+
+</section>
+
<section><title>Tools 3.1</title>
<section><title>Fixed Bugs and Malfunctions</title>
@@ -128,6 +186,36 @@
</section>
+<section><title>Tools 2.11.2.2</title>
+
+ <section><title>Fixed Bugs and Malfunctions</title>
+ <list>
+ <item>
+ <p><c>cover</c> would fail to start if two processes
+ tried to start it at the exact same time.</p>
+ <p>
+ Own Id: OTP-15813 Aux Id: ERL-943 </p>
+ </item>
+ </list>
+ </section>
+
+</section>
+
+<section><title>Tools 2.11.2.1</title>
+
+ <section><title>Fixed Bugs and Malfunctions</title>
+ <list>
+ <item>
+ <p>
+ Minor fixes for <c>make clean</c>.</p>
+ <p>
+ Own Id: OTP-15657</p>
+ </item>
+ </list>
+ </section>
+
+</section>
+
<section><title>Tools 2.11.2</title>
<section><title>Fixed Bugs and Malfunctions</title>
@@ -1905,4 +1993,3 @@
</section>
</section>
</chapter>
-
diff --git a/lib/tools/emacs/erlang-test.el b/lib/tools/emacs/erlang-test.el
index 2ee584d11a..fbdd298da3 100644
--- a/lib/tools/emacs/erlang-test.el
+++ b/lib/tools/emacs/erlang-test.el
@@ -50,8 +50,15 @@
;; The -L option adds a directory to the load-path. It should be the
;; directory containing erlang.el and erlang-test.el.
;;
-;; 3. Call the script test-erlang-mode in this directory. This script
-;; use the second method.
+;; 3. Run the emacs_SUITE. The testcases tests_interpreted/1 and
+;; tests_compiled/1 in this suite are using the second method. One
+;; way to run this suite is with the ct_run tool, for example like the
+;; following when standing at the OTP repo top directory:
+;;
+;; ct_run -suite lib/tools/test/emacs_SUITE
+;;
+;; Note that this creates a lot of html log files in the current
+;; directory.
;;; Code:
diff --git a/lib/tools/emacs/erlang.el b/lib/tools/emacs/erlang.el
index 3cbe9daa60..0b3a2319e2 100644
--- a/lib/tools/emacs/erlang.el
+++ b/lib/tools/emacs/erlang.el
@@ -4,7 +4,7 @@
;; Author: Anders Lindgren
;; Keywords: erlang, languages, processes
;; Date: 2011-12-11
-;; Version: 2.8.1
+;; Version: 2.8.2
;; Package-Requires: ((emacs "24.1"))
;; %CopyrightBegin%
@@ -87,7 +87,7 @@
"The Erlang programming language."
:group 'languages)
-(defconst erlang-version "2.8.1"
+(defconst erlang-version "2.8.2"
"The version number of Erlang mode.")
(defcustom erlang-root-dir nil
@@ -502,6 +502,13 @@ regardless of where in the line point is when the TAB command is used."
:type 'boolean
:safe 'booleanp)
+(defcustom erlang-max-files-to-visit-for-refining-xrefs 32
+ "Upper limit how many files to visit for checking arity.
+When `nil' there is no limit."
+ :group 'erlang
+ :type '(restricted-sexp :match-alternatives (integerp 'nil))
+ :safe (lambda (val) (or (eq val nil) (integerp val))))
+
(defvar erlang-man-inhibit (eq system-type 'windows-nt)
"Inhibit the creation of the Erlang Manual Pages menu.
@@ -905,8 +912,10 @@ resulting regexp is surrounded by \\_< and \\_>."
"dist_get_stat"
"dist_ctrl_get_data"
"dist_ctrl_get_data_notification"
+ "dist_ctrl_get_opt"
"dist_ctrl_input_handler"
"dist_ctrl_put_data"
+ "dist_ctrl_set_opt"
"dmonitor_node"
"dt_append_vm_tag_data"
"dt_get_tag"
@@ -3687,10 +3696,13 @@ When an identifier is found return a list with 4 elements:
module or nil.
2. Module - Module name string or nil. In case of a
-qualified-function a search fails if no entries with correct
-module are found. For other kinds the module is just a
-preference. If no matching entries are found the search will be
-retried without regard to module.
+qualified-function the module is explicitly specified (like
+module:fun()) and the search fails if no entries with correct
+module are found. For other kinds the module is guessed: either
+fetched from import statements or it is assumed to be the local
+module. In these cases the module is just a preference. If no
+matching entries are found the search will be retried without
+regard to module.
3. Name - String name of function, module, record or macro.
@@ -3702,18 +3714,22 @@ of arguments could be found, otherwise nil."
(if (eq (char-syntax (following-char)) ? )
(skip-chars-backward " \t"))
(skip-chars-backward "[:word:]_:'")
- (cond ((looking-at erlang-module-function-regexp)
+ (cond ((and (eq (preceding-char) ??)
+ (looking-at (concat "\\(MODULE\\):" erlang-atom-regexp)))
+ (erlang-get-qualified-function-id-at-point (erlang-get-module)))
+ ((looking-at erlang-module-function-regexp)
(erlang-get-qualified-function-id-at-point))
((looking-at (concat erlang-atom-regexp ":"))
(erlang-get-module-id-at-point))
((looking-at erlang-name-regexp)
(erlang-get-some-other-id-at-point)))))))
-(defun erlang-get-qualified-function-id-at-point ()
+(defun erlang-get-qualified-function-id-at-point (&optional module)
(let ((kind 'qualified-function)
- (module (erlang-remove-quotes
- (buffer-substring-no-properties
- (match-beginning 1) (match-end 1))))
+ (module (or module
+ (erlang-remove-quotes
+ (buffer-substring-no-properties
+ (match-beginning 1) (match-end 1)))))
(name (erlang-remove-quotes
(buffer-substring-no-properties
(match-beginning (1+ erlang-atom-regexp-matches))
@@ -3823,7 +3839,8 @@ of arguments could be found, otherwise nil."
(let ((case-fold-search nil)) ; force string matching to be case sensitive
(if (and (stringp str)
(not (string-match (eval-when-compile
- (concat "\\`" erlang-atom-regexp "\\'")) str)))
+ (concat "\\`" erlang-atom-regexp "\\'"))
+ str)))
(progn
(setq str (replace-regexp-in-string "'" "\\'" str t t ))
(concat "'" str "'"))
@@ -4877,15 +4894,36 @@ about Erlang modules."
;; The backend below is a wrapper around the built-in etags backend.
;; It adds awareness of the module:tag syntax in a similar way that is
;; done above for the old etags commands.
+;;
+;; In addition arity is also considered when jumping to definitions.
+;; There is however currently no information about arity in the TAGS
+;; file. Also two functions with the same name but different arity
+;; _sometimes_ get one TAGS entry each and sometimes are joined in one
+;; single entry. If they are directly consecutive they will be
+;; joined. If there are other functions etc in between then they will
+;; get one entry each.
+;;
+;; These limitations are present in both the etags program shipped
+;; with GNU Emacs and the tags.erl program in this repository.
+;;
+;; Therefore erlang.el must complement the information in TAGS by
+;; visiting files and checking arity. When searching for popular
+;; function names (like init, handle_call etc) in a big TAGS file
+;; (like one indexing this repository) this may be quite
+;; time-consuming. There exists therefore an upper limit for the
+;; number of files to visit (called
+;; `erlang-max-files-to-visit-for-refining-xrefs').
+;;
+;; As mentioned this xref implementation is based on the etags xref
+;; implementation. But in the cases where arity is considered the
+;; etags information structures (class xref-etags-location) will be
+;; translated to our own structures which include arity (class
+;; erlang-xref-location). This translation is started in the function
+;; `erlang-refine-xrefs'.
-(defvar erlang-current-arity nil
- "The arity of the function currently being searched.
-
-There is no information about arity in the TAGS file.
-Consecutive functions with same name but different arity will
-only get one entry in the TAGS file. Matching TAGS entries are
-therefore selected without regarding arity. The arity is
-considered first when it is time to jump to the definition.")
+;; I mention this as a head up that some of the functions below deal
+;; with xref items with xref-etags-location and some deal with xref
+;; items with erlang-xref-location.
(defun erlang-etags--xref-backend () 'erlang-etags)
@@ -4893,127 +4931,80 @@ considered first when it is time to jump to the definition.")
(when (locate-library (symbol-name feature))
(require feature)))
-(and (erlang-soft-require 'xref)
- (erlang-soft-require 'cl-generic)
- (erlang-soft-require 'eieio)
- (erlang-soft-require 'etags)
- ;; The purpose of using eval here is to avoid compilation
- ;; warnings in emacsen without cl-defmethod etc.
- (eval
- '(progn
- (cl-defmethod xref-backend-identifier-at-point
- ((_backend (eql erlang-etags)))
- (if (eq this-command 'xref-find-references)
- (if (use-region-p)
- (buffer-substring-no-properties (region-beginning)
- (region-end))
- (thing-at-point 'symbol))
- (erlang-id-to-string (erlang-get-identifier-at-point))))
-
- (cl-defmethod xref-backend-definitions
- ((_backend (eql erlang-etags)) identifier)
- (erlang-xref-find-definitions identifier))
-
- (cl-defmethod xref-backend-apropos
- ((_backend (eql erlang-etags)) identifier)
- (erlang-xref-find-definitions identifier t))
-
- (cl-defmethod xref-backend-identifier-completion-table
- ((_backend (eql erlang-etags)))
- (let ((erlang-replace-etags-tags-completion-table t))
- (tags-completion-table)))
-
- (defclass erlang-xref-location (xref-etags-location) ())
-
- (defun erlang-convert-xrefs (xrefs)
- (mapcar (lambda (xref)
- (oset xref location (erlang-make-location
- (oref xref location)))
- xref)
- xrefs))
-
- (defun erlang-make-location (etags-location)
- (with-slots (tag-info file) etags-location
- (make-instance 'erlang-xref-location :tag-info tag-info
- :file file)))
-
- (cl-defmethod xref-location-marker ((locus erlang-xref-location))
- (with-slots (tag-info file) locus
- (with-current-buffer (find-file-noselect file)
- (save-excursion
- (or (erlang-goto-tag-location-by-arity tag-info)
- (etags-goto-tag-location tag-info))
- ;; Reset erlang-current-arity. We want to jump to
- ;; correct arity in the first attempt. That is now
- ;; done. Possible remaining jumps will be from
- ;; entries in the *xref* buffer and then we want to
- ;; ignore the arity. (Alternatively we could remove
- ;; all but one xref entry per file when we know the
- ;; arity).
- (setq erlang-current-arity nil)
- (point-marker)))))
-
- (defun erlang-xref-context (xref)
- (with-slots (tag-info) (xref-item-location xref)
- (car tag-info))))))
-
-
-(defun erlang-goto-tag-location-by-arity (tag-info)
- (when erlang-current-arity
- (let* ((tag-text (car tag-info))
- (tag-pos (cdr (cdr tag-info)))
- (tag-line (car (cdr tag-info)))
- (regexp (erlang-tag-info-regexp tag-text))
- (startpos (or tag-pos
- (when tag-line
- (goto-char (point-min))
- (forward-line (1- tag-line))
- (point))
- (point-min))))
- (setq startpos (max (- startpos 2000)
- (point-min)))
- (goto-char startpos)
- (let ((pos (or (erlang-search-by-arity regexp)
- (unless (eq startpos (point-min))
- (goto-char (point-min))
- (erlang-search-by-arity regexp)))))
- (when pos
- (goto-char pos)
- t)))))
-
-(defun erlang-tag-info-regexp (tag-text)
- (concat "^"
- (regexp-quote tag-text)
- ;; Erlang function entries in TAGS includes the opening
- ;; parenthesis for the argument list. Erlang macro entries
- ;; do not. Add it here in order to end up in correct
- ;; position for erlang-get-arity.
- (if (string-prefix-p "-define" tag-text)
- "\\s-*("
- "")))
-
-(defun erlang-search-by-arity (regexp)
- (let (pos)
- (while (and (null pos)
- (re-search-forward regexp nil t))
- (when (eq erlang-current-arity (save-excursion (erlang-get-arity)))
- (setq pos (point-at-bol))))
- pos))
-
-
+(when (and (erlang-soft-require 'xref)
+ (erlang-soft-require 'cl-generic)
+ (erlang-soft-require 'eieio)
+ (erlang-soft-require 'etags))
+ ;; The purpose of using eval here is to avoid compilation
+ ;; warnings in emacsen without cl-defmethod etc.
+ (eval
+ '(progn
+ (cl-defmethod xref-backend-identifier-at-point ((_backend
+ (eql erlang-etags)))
+ (if (eq this-command 'xref-find-references)
+ (if (use-region-p)
+ (buffer-substring-no-properties (region-beginning)
+ (region-end))
+ (thing-at-point 'symbol))
+ (erlang-id-to-string (erlang-get-identifier-at-point))))
+
+ (cl-defmethod xref-backend-definitions ((_backend (eql erlang-etags))
+ identifier)
+ (erlang-xref-find-definitions identifier))
+
+ (cl-defmethod xref-backend-apropos ((_backend (eql erlang-etags))
+ identifier)
+ (erlang-xref-find-definitions identifier t))
+
+ (cl-defmethod xref-backend-identifier-completion-table
+ ((_backend (eql erlang-etags)))
+ (let ((erlang-replace-etags-tags-completion-table t))
+ (tags-completion-table)))
+
+ (defclass erlang-xref-location (xref-file-location)
+ ((arity :type fixnum :initarg :arity
+ :reader erlang-xref-location-arity))
+ :documentation "An erlang location is a file location plus arity.")
+
+ ;; This method definition only calls the superclass which is
+ ;; the default behaviour if it was not defined. It is only
+ ;; needed for "upgrade" purposes. In version 2.8.1 of
+ ;; erlang.el this method was defined differently and in case
+ ;; user switch to a new erlang.el without restarting Emacs
+ ;; this method needs to be redefined.
+ (cl-defmethod xref-location-marker ((locus erlang-xref-location))
+ (cl-call-next-method locus)))))
+
+;; If this function returns a single xref the user will jump to that
+;; directly. If two or more xrefs are returned a *xref* window is
+;; displayed and the user can choose where to jump. Hence we want to
+;; return a single xref when we are pretty sure that is where the user
+;; wants to go. Otherwise return all possible xrefs but sort them so
+;; that xrefs in the local file is first and if arity is known sort
+;; the xrefs with matching arity before others.
+
+;; Note that the arity sorting work may partly be undone later when
+;; the hits are presented in the *xref* buffer since they then will be
+;; grouped together by file. Ie when one file have one hit with
+;; correct arity and others with wrong arity these hits will be
+;; grouped together and may end up before hits with correct arity.
(defun erlang-xref-find-definitions (identifier &optional is-regexp)
(erlang-with-id (kind module name arity) identifier
- (setq erlang-current-arity arity)
(cond ((eq kind 'module)
(erlang-xref-find-definitions-module name))
+ ((eq kind 'qualified-function)
+ (erlang-xref-find-definitions-qualified-function module
+ name
+ arity
+ is-regexp))
(module
- (erlang-xref-find-definitions-module-tag module
+ (erlang-xref-find-definitions-module-tag kind
+ module
name
- (eq kind
- 'qualified-function)
+ arity
is-regexp))
(t
- (erlang-xref-find-definitions-tag kind name is-regexp)))))
+ (erlang-xref-find-definitions-tag kind name arity is-regexp)))))
(defun erlang-xref-find-definitions-module (module)
(and (fboundp 'xref-make)
@@ -5038,65 +5029,252 @@ considered first when it is time to jump to the definition.")
(setq files (cdr files))))))
(nreverse xrefs))))
-(defun erlang-visit-tags-table-buffer (cont cbuf)
- (if (< emacs-major-version 26)
- (visit-tags-table-buffer cont)
- ;; Remove this with-no-warnings when Emacs 26 is the required
- ;; version minimum.
- (with-no-warnings
- (visit-tags-table-buffer cont cbuf))))
-
-(defun erlang-xref-find-definitions-module-tag (module
+(defun erlang-xref-find-definitions-qualified-function (module
+ tag
+ arity
+ is-regexp)
+ "Find definitions of TAG in MODULE preferably with arity ARITY.
+If one single perfect match was found return only that (ignoring
+other definitions matching TAG). If IS-REGEXP is non-nil then
+TAG is a regexp."
+ (let* ((xrefs (when (fboundp 'etags--xref-find-definitions)
+ (etags--xref-find-definitions tag is-regexp)))
+ (xrefs-split (erlang-split-xrefs-on-module xrefs module))
+ (module-xrefs (car xrefs-split))
+ (module-xrefs (erlang-refine-xrefs module-xrefs
+ 'qualified-function
+ tag
+ is-regexp)))
+ (or (erlang-single-arity-match module-xrefs arity)
+ (erlang-sort-by-arity module-xrefs arity))))
+
+
+;; We will end up here when erlang-get-some-other-id-at-point either
+;; found module among the import statements or module is just the
+;; current local file.
+(defun erlang-xref-find-definitions-module-tag (kind
+ module
tag
- is-qualified
+ arity
is-regexp)
- "Find definitions of TAG and filter away definitions outside of
-MODULE. If IS-QUALIFIED is nil and no definitions was found inside
-the MODULE then return any definitions found outside. If
-IS-REGEXP is non-nil then TAG is a regexp."
- (and (fboundp 'etags--xref-find-definitions)
- (fboundp 'erlang-convert-xrefs)
- (let ((xrefs (erlang-convert-xrefs
- (etags--xref-find-definitions tag is-regexp)))
- xrefs-in-module)
- (dolist (xref xrefs)
- (when (string-equal module (erlang-xref-module xref))
- (push xref xrefs-in-module)))
- (cond (is-qualified xrefs-in-module)
- (xrefs-in-module xrefs-in-module)
- (t xrefs)))))
-
-(defun erlang-xref-find-definitions-tag (kind tag is-regexp)
- "Find all definitions of TAG and reorder them so that
-definitions in the currently visited file comes first."
- (and (fboundp 'etags--xref-find-definitions)
- (fboundp 'erlang-convert-xrefs)
- (let* ((current-file (and (buffer-file-name)
- (file-truename (buffer-file-name))))
- (regexp (erlang-etags-regexp kind tag is-regexp))
- (xrefs (erlang-convert-xrefs
- (etags--xref-find-definitions regexp t)))
- local-xrefs non-local-xrefs)
- (while xrefs
- (let ((xref (car xrefs)))
- (if (string-equal (erlang-xref-truename-file xref)
- current-file)
- (push xref local-xrefs)
- (push xref non-local-xrefs))
- (setq xrefs (cdr xrefs))))
- (append (reverse local-xrefs)
- (reverse non-local-xrefs)))))
+ "Find definitions of TAG preferably in MODULE and with arity ARITY.
+Return definitions outside MODULE if none are found inside. If
+IS-REGEXP is non-nil then TAG is a regexp.
+
+If one single perfect match was found return only that (ignoring
+other definitions matching TAG)."
+ (let* ((xrefs (when (fboundp 'etags--xref-find-definitions)
+ (etags--xref-find-definitions tag is-regexp)))
+ (xrefs-split (erlang-split-xrefs-on-module xrefs module))
+ (module-xrefs (car xrefs-split))
+ (module-xrefs (erlang-refine-xrefs module-xrefs
+ kind
+ tag
+ is-regexp)))
+ (or (erlang-single-arity-match module-xrefs arity)
+ (erlang-xref-find-definitions-tag kind tag arity is-regexp xrefs))))
+
+(defun erlang-xref-find-definitions-tag (kind
+ tag
+ arity
+ is-regexp
+ &optional xrefs)
+ "Find definitions of TAG preferably in local file and with arity ARITY.
+If one single perfect match was found return only that (ignoring
+other definitions matching TAG). If no such local match was
+found then look for a matching BIF in the same way. If IS-REGEXP
+is non-nil then TAG is a regexp."
+ (let* ((regexp (erlang-etags-regexp kind tag is-regexp))
+ (xrefs (or xrefs
+ (when (fboundp 'etags--xref-find-definitions)
+ (etags--xref-find-definitions regexp t))))
+ (xrefs-split (erlang-split-xrefs xrefs))
+ (local-xrefs (car xrefs-split))
+ (local-xrefs (erlang-refine-xrefs local-xrefs
+ kind
+ tag
+ is-regexp))
+ (bif-xrefs (cadr xrefs-split))
+ (other-xrefs (caddr xrefs-split)))
+ (or (erlang-single-arity-match local-xrefs arity)
+ ;; No local match, look for a matching BIF.
+ (progn
+ (setq bif-xrefs (erlang-refine-xrefs bif-xrefs
+ kind
+ tag
+ is-regexp))
+ (erlang-single-arity-match bif-xrefs arity))
+ (progn
+ (setq other-xrefs (erlang-refine-xrefs other-xrefs
+ kind
+ tag
+ is-regexp))
+ (and (null local-xrefs)
+ (null bif-xrefs)
+ ;; No local of BIF matches at all. Is there a single
+ ;; arity match among the rest?
+ (erlang-single-arity-match other-xrefs arity)))
+ (append (erlang-sort-by-arity local-xrefs arity)
+ (erlang-sort-by-arity bif-xrefs arity)
+ (erlang-sort-by-arity other-xrefs arity)))))
+
+
+(defun erlang-refine-xrefs (xrefs kind tag is-regexp)
+ (if (or (memq kind '(record module))
+ ;; No support for apropos here.
+ is-regexp
+ (erlang-too-many-files-in-xrefs xrefs))
+ xrefs
+ (when (and xrefs
+ (fboundp 'xref-item-location)
+ (fboundp 'xref-location-group)
+ (fboundp 'slot-value))
+ (let (files)
+ (cl-loop for xref in xrefs
+ for loc = (xref-item-location xref)
+ for file = (xref-location-group loc)
+ do (pushnew file files :test 'string-equal))
+ (or (cl-loop for file in files
+ append (erlang-xrefs-in-file file kind tag is-regexp))
+ ;; Failed for some reason. Pretend like it is raining and
+ ;; return the unrefined xrefs.
+ xrefs)))))
+
+(defun erlang-too-many-files-in-xrefs (xrefs)
+ (and erlang-max-files-to-visit-for-refining-xrefs
+ (let ((files-to-visit (delete-dups
+ (mapcar #'erlang-xref-truename-file
+ xrefs))))
+ (if (< (length files-to-visit)
+ erlang-max-files-to-visit-for-refining-xrefs)
+ nil
+ (message (concat "Too many hits to consider arity (see "
+ "`erlang-max-files-to-visit-for-refining-xrefs')"))
+ t))))
+
+(defun erlang-xrefs-in-file (file kind tag is-regexp)
+ (when (fboundp 'make-instance)
+ (with-current-buffer (find-file-noselect file)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((regexp (concat ; "^"
+ (erlang-etags-regexp kind tag is-regexp)
+ "\\s *("))
+ last-arity)
+ (cl-loop while (re-search-forward regexp nil t)
+ for name = (match-string-no-properties 1)
+ for arity = (save-excursion
+ (erlang-get-arity))
+ for loc = (make-instance 'erlang-xref-location
+ :file file
+ :line (line-number-at-pos)
+ :column 0
+ :arity arity)
+ for sum = (erlang-xref-summary kind name arity)
+ when (and arity
+ (not (eq arity last-arity)))
+ collect (make-instance 'xref-item
+ :summary sum
+ :location loc)
+ do (setq last-arity arity)))))))
+
+(defun erlang-xref-summary (kind tag arity)
+ (format "%s%s%s"
+ (if (memq kind '(record macro module))
+ (format "%s " kind)
+ "")
+ tag
+ (if arity (format "/%s" arity) "")))
+
+(defun erlang-single-arity-match (xrefs wanted-arity)
+ "Attempt to find one perfect match.
+
+If we have all information needed to consider arity then return a
+single perfect match or nothing. If there are more than one
+match nothing is returned.
+
+If we don't have all information needed to consider arity just
+return XREFS as is."
+ (if (erlang-should-consider-arity-p xrefs wanted-arity)
+ (let ((nr-matches 0)
+ match)
+ (while (and xrefs
+ (< nr-matches 2))
+ (let* ((xref (car xrefs))
+ (arity (erlang-xref-arity xref)))
+ (when (eq arity wanted-arity)
+ (setq match xref
+ nr-matches (1+ nr-matches)))
+ (setq xrefs (cdr xrefs))))
+ (when (eq nr-matches 1)
+ (list match)))
+ (when (eq (length xrefs) 1)
+ xrefs)))
+
+(defun erlang-sort-by-arity (xrefs wanted-arity)
+ (if (erlang-should-consider-arity-p xrefs wanted-arity)
+ (let (matches non-matches)
+ (while xrefs
+ (let* ((xref (car xrefs))
+ (arity (erlang-xref-arity xref)))
+ (push xref (if (eq arity wanted-arity)
+ matches
+ non-matches))
+ (setq xrefs (cdr xrefs))))
+ (append (reverse matches) (reverse non-matches) xrefs))
+ xrefs))
+
+(defun erlang-should-consider-arity-p (xrefs wanted-arity)
+ (and wanted-arity
+ xrefs
+ (fboundp 'erlang-xref-location-p)
+ (fboundp 'xref-item-location)
+ (erlang-xref-location-p (xref-item-location (car xrefs)))))
(defun erlang-etags-regexp (kind tag is-regexp)
- (let ((tag-regexp (if is-regexp
- tag
- (regexp-quote tag))))
- (cond ((eq kind 'record)
- (concat "-record\\s-*(\\s-*" tag-regexp))
- ((eq kind 'macro)
- (concat "-define\\s-*(\\s-*" tag-regexp))
- (t tag-regexp))))
-
+ (let ((tag-regexp (concat "\\("
+ (if is-regexp
+ tag
+ (regexp-quote tag))
+ "\\)")))
+ (concat (if is-regexp "" "^")
+ (cond ((eq kind 'record)
+ (concat "-record\\s-*(\\s-*" tag-regexp))
+ ((eq kind 'macro)
+ (concat "-define\\s-*(\\s-*" tag-regexp))
+ (t
+ tag-regexp))
+ (if is-regexp "" "\\_>"))))
+
+(defun erlang-xref-arity (xref)
+ (and (fboundp 'erlang-xref-location-arity)
+ (fboundp 'xref-item-location)
+ (erlang-xref-location-arity (xref-item-location xref))))
+
+(defun erlang-split-xrefs-on-module (xrefs module)
+ (let (local-xrefs non-local-xrefs)
+ (dolist (xref xrefs)
+ (if (string-equal (erlang-xref-module xref)
+ module)
+ (push xref local-xrefs)
+ (push xref non-local-xrefs)))
+ (cons (reverse local-xrefs)
+ (reverse non-local-xrefs))))
+
+(defun erlang-split-xrefs (xrefs)
+ (let ((current-file (and (buffer-file-name)
+ (file-truename (buffer-file-name))))
+ local-xrefs bif-xrefs other-xrefs)
+ (dolist (xref xrefs)
+ (cond ((string-equal (erlang-xref-truename-file xref) current-file)
+ (push xref local-xrefs))
+ ((string-equal (erlang-xref-module xref) "erlang")
+ (push xref bif-xrefs))
+ (t
+ (push xref other-xrefs))))
+ (list (reverse local-xrefs)
+ (reverse bif-xrefs)
+ (reverse other-xrefs))))
(defun erlang-xref-module (xref)
(erlang-get-module-from-file-name (erlang-xref-file xref)))
@@ -5111,7 +5289,13 @@ definitions in the currently visited file comes first."
(fboundp 'xref-item-location)
(xref-location-group (xref-item-location xref))))
-
+(defun erlang-visit-tags-table-buffer (cont cbuf)
+ (if (< emacs-major-version 26)
+ (visit-tags-table-buffer cont)
+ ;; Remove this with-no-warnings when Emacs 26 is the required
+ ;; version minimum.
+ (with-no-warnings
+ (visit-tags-table-buffer cont cbuf))))
;;;
;;; Prepare for other methods to run an Erlang slave process.
diff --git a/lib/tools/emacs/erldoc.el b/lib/tools/emacs/erldoc.el
index 770ab299ee..bc16d7a14d 100644
--- a/lib/tools/emacs/erldoc.el
+++ b/lib/tools/emacs/erldoc.el
@@ -89,6 +89,13 @@ up the indexing."
:type 'file
:group 'erldoc)
+(defcustom erldoc-no-signature-function #'ignore
+ "Notification function called if no function signature was found."
+ :type '(choice (function-item :tag "Ignore" ignore)
+ (function-item :tag "Warn" warn)
+ (function-item :tag "Error" error))
+ :group 'erldoc)
+
(defun erldoc-strip-string (s)
(let* ((re "[ \t\n\r\f\v\u00a0]+")
(from (if (string-match (concat "\\`" re) s) (match-end 0) 0))
@@ -212,11 +219,21 @@ up the indexing."
;; Get the full function signature.
(when (and (eq (car-safe d) 'a)
(gethash (erldoc-dom-get-attribute d 'name) table))
- (push (append (gethash (erldoc-dom-get-attribute d 'name) table)
- (list (funcall span-content
- (or (erldoc-dom-get-element d 'span)
- (cadr (memq d erldoc-dom-walk-siblings))))))
- entries))
+ (let* ((name (erldoc-dom-get-attribute d 'name))
+ (mfa-url (gethash name table))
+ (mfa (car mfa-url))
+ (sig (or (funcall span-content d)
+ (funcall span-content
+ (or (erldoc-dom-get-element d 'span)
+ (cadr
+ (memq d erldoc-dom-walk-siblings))))
+ (progn
+ (funcall erldoc-no-signature-function
+ "erldoc-parse-man: no sig for %s"
+ mfa)
+ nil))))
+ (push (append mfa-url (list sig))
+ entries)))
;; Get data types
(when (and (eq (car-safe d) 'a)
(string-prefix-p "type-"
@@ -280,7 +297,7 @@ up the indexing."
(unless (file-exists-p of)
(erldoc-parse-all erldoc-man-index of))
(unless (string= erldoc-output-file of)
- (make-symbolic-link of erldoc-output-file))))
+ (make-symbolic-link (expand-file-name of) erldoc-output-file))))
(setq erldoc-lookup-table
(with-temp-buffer
(insert-file-contents erldoc-output-file)
@@ -356,9 +373,12 @@ up the indexing."
(sigs))
(maphash (lambda (k v)
(when (string-match re k)
- (push (cons (string-to-number (match-string 1 k))
- (cdr (erldoc-tokenize-signature (cadr v))))
- sigs)))
+ (if (cadr v)
+ (push (cons (string-to-number (match-string 1 k))
+ (cdr (erldoc-tokenize-signature (cadr v))))
+ sigs)
+ (funcall erldoc-no-signature-function
+ "erldoc-format-signature: No sig for %s" k))))
(erldoc-lookup-table))
(when sigs
;; Mostly single return type but there are exceptions such as
diff --git a/lib/tools/src/cover.erl b/lib/tools/src/cover.erl
index 8d4561ca9e..2b3af417b6 100644
--- a/lib/tools/src/cover.erl
+++ b/lib/tools/src/cover.erl
@@ -23,6 +23,7 @@
%% This module implements the Erlang coverage tool.
%%
%% ARCHITECTURE
+%%
%% The coverage tool consists of one process on each node involved in
%% coverage analysis. The process is registered as 'cover_server'
%% (?SERVER). The cover_server on the 'main' node is in charge, and
@@ -30,45 +31,62 @@
%% 'DOWN' message for another cover_server, it marks the node as
%% 'lost'. If a nodeup is received for a lost node the main node
%% ensures that the cover compiled modules are loaded again. If the
-%% remote node was alive during the disconnected periode, cover data
-%% for this periode will also be included in the analysis.
+%% remote node was alive during the disconnected period, cover data
+%% for this period will also be included in the analysis.
%%
%% The cover_server process on the main node is implemented by the
%% functions init_main/1 and main_process_loop/1. The cover_server on
%% the remote nodes are implemented by the functions init_remote/2 and
%% remote_process_loop/1.
%%
+%% COUNTERS
+%%
+%% The 'counters' modules is used for counting how many time each line
+%% executed. Each cover-compiled module will have its own array of
+%% counters.
+%%
+%% The counter reference for module Module is stored in a persistent
+%% term with the key {cover,Module}.
+%%
+%% When the cover:local_only/0 function has been called, the reference
+%% for the counter array will be compiled into each cover-compiled
+%% module directly (instead of retrieving it from a persistent term).
+%% That will be faster, but the resulting code can be only be used on
+%% the main node.
+%%
%% TABLES
-%% Each nodes has two tables: cover_internal_data_table (?COVER_TABLE) and.
-%% cover_internal_clause_table (?COVER_CLAUSE_TABLE).
-%% ?COVER_TABLE contains the bump data i.e. the data about which lines
-%% have been executed how many times.
+%%
+%% Each node has two tables: ?COVER_MAPPING_TABLE and ?COVER_CLAUSE_TABLE.
+%% ?COVER_MAPPING_TABLE maps from a #bump{} record to an index in the
+%% counter array for the module. It is used both during instrumentation
+%% of cover-compiled modules and when collecting the counter values.
+%%
%% ?COVER_CLAUSE_TABLE contains information about which clauses in which modules
%% cover is currently collecting statistics.
-%%
-%% The main node owns tables named
-%% 'cover_collected_remote_data_table' (?COLLECTION_TABLE) and
-%% 'cover_collected_remote_clause_table' (?COLLECTION_CLAUSE_TABLE).
-%% These tables contain data which is collected from remote nodes (either when a
-%% remote node is stopped with cover:stop/1 or when analysing). When
-%% analysing, data is even moved from the COVER tables on the main
-%% node to the COLLECTION tables.
%%
-%% The main node also has a table named 'cover_binary_code_table'
-%% (?BINARY_TABLE). This table contains the binary code for each cover
-%% compiled module. This is necessary so that the code can be loaded
-%% on remote nodes that are started after the compilation.
+%% The main node owns the tables ?COLLECTION_TABLE and
+%% ?COLLECTION_CLAUSE_TABLE. The counter data is consolidated into those
+%% tables from the counters on both the main node and from remote nodes.
+%% This consolidation is done when a remote node is stopped with
+%% cover:stop/1 or just before starting an analysis.
+%%
+%% The main node also has a table named ?BINARY_TABLE. This table
+%% contains the abstract code code for each cover-compiled
+%% module. This is necessary so that the code can be loaded on remote
+%% nodes that are started after the compilation.
%%
%% PARALLELISM
+%%
%% To take advantage of SMP when doing the cover analysis both the data
%% collection and analysis has been parallelized. One process is spawned for
%% each node when collecting data, and on the remote node when collecting data
%% one process is spawned per module.
%%
-%% When analyzing data it is possible to issue multiple analyse(_to_file)/X
-%% calls at once. They are however all calls (for backwards compatibility
-%% reasons) so the user of cover will have to spawn several processes to to the
-%% calls ( or use async_analyse_to_file ).
+%% When analyzing data it is possible to issue multiple
+%% analyse(_to_file)/X calls at once. They are, however, all calls
+%% (for backwards compatibility reasons), so the user of cover will
+%% have to spawn several processes to to the calls (or use
+%% async_analyse_to_file/X).
%%
%% External exports
@@ -89,7 +107,8 @@
modules/0, imported/0, imported_modules/0, which_nodes/0, is_compiled/1,
reset/1, reset/0,
flush/1,
- stop/0, stop/1]).
+ stop/0, stop/1,
+ local_only/0]).
-export([remote_start/1,get_main_node/0]).
%% Used internally to ensure we upgrade the code to the latest version.
@@ -98,9 +117,16 @@
-record(main_state, {compiled=[], % [{Module,File}]
imported=[], % [{Module,File,ImportFile}]
stopper, % undefined | pid()
+ local_only=false, % true | false
nodes=[], % [Node]
lost_nodes=[]}). % [Node]
+-record(remote_data, {module,
+ file,
+ code,
+ mapping,
+ clauses}).
+
-record(remote_state, {compiled=[], % [{Module,File}]
main_node}). % atom()
@@ -126,11 +152,12 @@
is_guard=false % boolean
}).
--define(COVER_TABLE, 'cover_internal_data_table').
+-define(COVER_MAPPING_TABLE, 'cover_internal_mapping_table').
-define(COVER_CLAUSE_TABLE, 'cover_internal_clause_table').
-define(BINARY_TABLE, 'cover_binary_code_table').
-define(COLLECTION_TABLE, 'cover_collected_remote_data_table').
-define(COLLECTION_CLAUSE_TABLE, 'cover_collected_remote_clause_table').
+
-define(TAG, cover_compiled).
-define(SERVER, cover_server).
@@ -169,6 +196,8 @@ start() ->
receive
{?SERVER,started} ->
{ok,Pid};
+ {?SERVER,{error,Error}} ->
+ {error,Error};
{'DOWN', Ref, _Type, _Object, Info} ->
{error,Info}
end,
@@ -186,6 +215,11 @@ start(Node) when is_atom(Node) ->
start(Nodes) ->
call({start_nodes,remove_myself(Nodes,[])}).
+%% local_only() -> ok | {error,too_late}
+
+local_only() ->
+ call(local_only).
+
%% compile(ModFiles) ->
%% compile(ModFiles, Options) ->
%% compile_module(ModFiles) -> Result
@@ -255,15 +289,8 @@ compile_directory(Dir, Options) when is_list(Dir), is_list(Options) ->
compile_modules(Files,Options) ->
Options2 = filter_options(Options),
- %% compile_modules(Files,Options2,[]).
call({compile, Files, Options2}).
-%% compile_modules([File|Files], Options, Result) ->
-%% R = call({compile, File, Options}),
-%% compile_modules(Files,Options,[R|Result]);
-%% compile_modules([],_Opts,Result) ->
-%% lists:reverse(Result).
-
filter_options(Options) ->
lists:filter(fun(Option) ->
case Option of
@@ -561,16 +588,6 @@ flush(Nodes) ->
get_main_node() ->
call(get_main_node).
-%% bump(Module, Function, Arity, Clause, Line)
-%% Module = Function = atom()
-%% Arity = Clause = Line = integer()
-%% This function is inserted into Cover compiled modules, once for each
-%% executable line.
-%bump(Module, Function, Arity, Clause, Line) ->
-% Key = #bump{module=Module, function=Function, arity=Arity, clause=Clause,
-% line=Line},
-% ets:update_counter(?COVER_TABLE, Key, 1).
-
call(Request) ->
Ref = erlang:monitor(process,?SERVER),
receive {'DOWN', Ref, _Type, _Object, noproc} ->
@@ -630,28 +647,54 @@ remote_reply(MainNode,Reply) ->
%%%----------------------------------------------------------------------
init_main(Starter) ->
- register(?SERVER,self()),
- %% Having write concurrancy here gives a 40% performance boost
- %% when collect/1 is called.
- ?COVER_TABLE = ets:new(?COVER_TABLE, [set, public, named_table,
- {write_concurrency, true}]),
- ?COVER_CLAUSE_TABLE = ets:new(?COVER_CLAUSE_TABLE, [set, public,
- named_table]),
- ?BINARY_TABLE = ets:new(?BINARY_TABLE, [set, public, named_table]),
- ?COLLECTION_TABLE = ets:new(?COLLECTION_TABLE, [set, public,
- named_table]),
- ?COLLECTION_CLAUSE_TABLE = ets:new(?COLLECTION_CLAUSE_TABLE, [set, public,
- named_table]),
- ok = net_kernel:monitor_nodes(true),
- Starter ! {?SERVER,started},
- main_process_loop(#main_state{}).
+ try register(?SERVER,self()) of
+ true ->
+ ?COVER_MAPPING_TABLE = ets:new(?COVER_MAPPING_TABLE,
+ [ordered_set, public, named_table]),
+ ?COVER_CLAUSE_TABLE = ets:new(?COVER_CLAUSE_TABLE, [set, public,
+ named_table]),
+ ?BINARY_TABLE = ets:new(?BINARY_TABLE, [set, public, named_table]),
+ ?COLLECTION_TABLE = ets:new(?COLLECTION_TABLE, [set, public,
+ named_table]),
+ ?COLLECTION_CLAUSE_TABLE = ets:new(?COLLECTION_CLAUSE_TABLE,
+ [set, public, named_table]),
+ ok = net_kernel:monitor_nodes(true),
+ Starter ! {?SERVER,started},
+ main_process_loop(#main_state{})
+ catch
+ error:badarg ->
+ %% The server's already registered; either report that it's already
+ %% started or try again if it died before we could find its pid.
+ case whereis(?SERVER) of
+ undefined ->
+ init_main(Starter);
+ Pid ->
+ Starter ! {?SERVER, {error, {already_started, Pid}}}
+ end
+ end.
main_process_loop(State) ->
receive
+ {From, local_only} ->
+ case State of
+ #main_state{compiled=[],nodes=[]} ->
+ reply(From, ok),
+ main_process_loop(State#main_state{local_only=true});
+ #main_state{} ->
+ reply(From, {error,too_late}),
+ main_process_loop(State)
+ end;
+
{From, {start_nodes,Nodes}} ->
- {StartedNodes,State1} = do_start_nodes(Nodes, State),
- reply(From, {ok,StartedNodes}),
- main_process_loop(State1);
+ case State#main_state.local_only of
+ false ->
+ {StartedNodes,State1} = do_start_nodes(Nodes, State),
+ reply(From, {ok,StartedNodes}),
+ main_process_loop(State1);
+ true ->
+ reply(From, {error,local_only}),
+ main_process_loop(State)
+ end;
{From, {compile, Files, Options}} ->
{R,S} = do_compile(Files, Options, State),
@@ -742,11 +785,12 @@ main_process_loop(State) ->
end,
State#main_state.nodes),
reload_originals(State#main_state.compiled),
- ets:delete(?COVER_TABLE),
+ ets:delete(?COVER_MAPPING_TABLE),
ets:delete(?COVER_CLAUSE_TABLE),
ets:delete(?BINARY_TABLE),
ets:delete(?COLLECTION_TABLE),
ets:delete(?COLLECTION_CLAUSE_TABLE),
+ delete_all_counters(),
unregister(?SERVER),
reply(From, ok);
@@ -878,10 +922,8 @@ main_process_loop(State) ->
init_remote(Starter,MainNode) ->
register(?SERVER,self()),
- %% write_concurrency here makes otp_8270 break :(
- ?COVER_TABLE = ets:new(?COVER_TABLE, [set, public, named_table
- %,{write_concurrency, true}
- ]),
+ ?COVER_MAPPING_TABLE = ets:new(?COVER_MAPPING_TABLE,
+ [ordered_set, public, named_table]),
?COVER_CLAUSE_TABLE = ets:new(?COVER_CLAUSE_TABLE, [set, public,
named_table]),
Starter ! {self(),started},
@@ -904,7 +946,7 @@ remote_process_loop(State) ->
remote_process_loop(State#remote_state{compiled=Compiled});
{remote,reset,Module} ->
- do_reset(Module),
+ reset_counters(Module),
remote_reply(State#remote_state.main_node, ok),
remote_process_loop(State);
@@ -925,8 +967,9 @@ remote_process_loop(State) ->
{remote,stop} ->
reload_originals(State#remote_state.compiled),
- ets:delete(?COVER_TABLE),
+ ets:delete(?COVER_MAPPING_TABLE),
ets:delete(?COVER_CLAUSE_TABLE),
+ delete_all_counters(),
unregister(?SERVER),
ok; % not replying since 'DOWN' message will be received anyway
@@ -961,28 +1004,12 @@ remote_process_loop(State) ->
end.
do_collect(Modules, CollectorPid, From) ->
- _ = pmap(
- fun(Module) ->
- Pattern = {#bump{module=Module, _='_'}, '$1'},
- MatchSpec = [{Pattern,[{'=/=','$1',0}],['$_']}],
- Match = ets:select(?COVER_TABLE,MatchSpec,?CHUNK_SIZE),
- send_chunks(Match, CollectorPid, [])
- end,Modules),
+ _ = pmap(fun(Module) ->
+ send_counters(Module, CollectorPid)
+ end, Modules),
CollectorPid ! done,
remote_reply(From, ok).
-send_chunks('$end_of_table', _CollectorPid, Mons) ->
- get_downs(Mons);
-send_chunks({Chunk,Continuation}, CollectorPid, Mons) ->
- Mon = spawn_monitor(
- fun() ->
- lists:foreach(fun({Bump,_N}) ->
- ets:insert(?COVER_TABLE, {Bump,0})
- end,
- Chunk) end),
- send_chunk(CollectorPid,Chunk),
- send_chunks(ets:select(Continuation), CollectorPid, [Mon|Mons]).
-
send_chunk(CollectorPid,Chunk) ->
CollectorPid ! {chunk,Chunk,self()},
receive continue -> ok end.
@@ -1021,10 +1048,15 @@ do_reload_original(Module) ->
ignore
end.
-load_compiled([{Module,File,Binary,InitialTable}|Compiled],Acc) ->
- %% Make sure the #bump{} records are available *before* the
- %% module is loaded.
- insert_initial_data(InitialTable),
+load_compiled([Data|Compiled],Acc) ->
+ %% Make sure the #bump{} records and counters are available *before*
+ %% compiling and loading the code.
+ #remote_data{module=Module,file=File,code=Beam,
+ mapping=InitialMapping,clauses=InitialClauses} = Data,
+ ets:insert(?COVER_MAPPING_TABLE, InitialMapping),
+ ets:insert(?COVER_CLAUSE_TABLE, InitialClauses),
+ maybe_create_counters(Module, true),
+
Sticky = case code:is_sticky(Module) of
true ->
code:unstick_mod(Module),
@@ -1032,7 +1064,7 @@ load_compiled([{Module,File,Binary,InitialTable}|Compiled],Acc) ->
false ->
false
end,
- NewAcc = case code:load_binary(Module, ?TAG, Binary) of
+ NewAcc = case code:load_binary(Module, ?TAG, Beam) of
{module,Module} ->
add_compiled(Module, File, Acc);
_ ->
@@ -1047,16 +1079,6 @@ load_compiled([{Module,File,Binary,InitialTable}|Compiled],Acc) ->
load_compiled([],Acc) ->
Acc.
-insert_initial_data([Item|Items]) when is_atom(element(1,Item)) ->
- ets:insert(?COVER_CLAUSE_TABLE, Item),
- insert_initial_data(Items);
-insert_initial_data([Item|Items]) ->
- ets:insert(?COVER_TABLE, Item),
- insert_initial_data(Items);
-insert_initial_data([]) ->
- ok.
-
-
unload([Module|Modules]) ->
do_clear(Module),
do_reload_original(Module),
@@ -1177,7 +1199,7 @@ get_downs_r([]) ->
[];
get_downs_r(Mons) ->
receive
- {'DOWN', Ref, _Type, Pid, R={_,_,_,_}} ->
+ {'DOWN', Ref, _Type, Pid, #remote_data{}=R} ->
[R|get_downs_r(lists:delete({Pid,Ref},Mons))];
{'DOWN', Ref, _Type, Pid, Reason} = Down ->
case lists:member({Pid,Ref},Mons) of
@@ -1196,19 +1218,13 @@ get_downs_r(Mons) ->
%% Binary is the beam code for the module and InitialTable is the initial
%% data to insert in ?COVER_TABLE.
get_data_for_remote_loading({Module,File}) ->
- [{Module,Binary}] = ets:lookup(?BINARY_TABLE,Module),
+ [{Module,Code}] = ets:lookup(?BINARY_TABLE, Module),
%%! The InitialTable list will be long if the module is big - what to do??
- InitialBumps = ets:select(?COVER_TABLE,ms(Module)),
+ Mapping = counters_mapping_table(Module),
InitialClauses = ets:lookup(?COVER_CLAUSE_TABLE,Module),
- {Module,File,Binary,InitialBumps ++ InitialClauses}.
-
-%% Create a match spec which returns the clause info {Module,InitInfo} and
-%% all #bump keys for the given module with 0 number of calls.
-ms(Module) ->
- ets:fun2ms(fun({Key,_}) when Key#bump.module=:=Module ->
- {Key,0}
- end).
+ #remote_data{module=Module,file=File,code=Code,
+ mapping=Mapping,clauses=InitialClauses}.
%% Unload modules on remote nodes
remote_unload(Nodes,UnloadedModules) ->
@@ -1464,7 +1480,7 @@ get_compiled_still_loaded(Nodes,Compiled0) ->
do_compile_beams(ModsAndFiles, State) ->
Result0 = pmap(fun({ok,Module,File}) ->
- do_compile_beam(Module,File,State);
+ do_compile_beam(Module, File, State);
(Error) ->
Error
end,
@@ -1476,8 +1492,10 @@ do_compile_beams(ModsAndFiles, State) ->
do_compile_beam(Module,BeamFile0,State) ->
case get_beam_file(Module,BeamFile0,State#main_state.compiled) of
{ok,BeamFile} ->
+ LocalOnly = State#main_state.local_only,
UserOptions = get_compile_options(Module,BeamFile),
- case do_compile_beam1(Module,BeamFile,UserOptions) of
+ case do_compile_beam1(Module,BeamFile,
+ UserOptions,LocalOnly) of
{ok, Module} ->
{ok,Module,BeamFile};
error ->
@@ -1503,41 +1521,39 @@ fix_state_and_result([],State,Acc) ->
do_compile(Files, Options, State) ->
+ LocalOnly = State#main_state.local_only,
Result0 = pmap(fun(File) ->
- do_compile(File, Options)
+ do_compile1(File, Options, LocalOnly)
end,
Files),
Compiled = [{M,F} || {ok,M,F} <- Result0],
remote_load_compiled(State#main_state.nodes,Compiled),
fix_state_and_result(Result0,State,[]).
-do_compile(File, Options) ->
- case do_compile1(File, Options) of
+do_compile1(File, Options, LocalOnly) ->
+ case do_compile2(File, Options, LocalOnly) of
{ok, Module} ->
{ok,Module,File};
error ->
{error,File}
end.
-%% do_compile1(File, Options) -> {ok,Module} | error
-do_compile1(File, UserOptions) ->
+%% do_compile2(File, Options) -> {ok,Module} | error
+do_compile2(File, UserOptions, LocalOnly) ->
Options = [debug_info,binary,report_errors,report_warnings] ++ UserOptions,
case compile:file(File, Options) of
{ok, Module, Binary} ->
- do_compile_beam1(Module,Binary,UserOptions);
+ do_compile_beam1(Module,Binary,UserOptions,LocalOnly);
error ->
error
end.
%% Beam is a binary or a .beam file name
-do_compile_beam1(Module,Beam,UserOptions) ->
+do_compile_beam1(Module,Beam,UserOptions,LocalOnly) ->
%% Clear database
do_clear(Module),
- %% Extract the abstract format and insert calls to bump/6 at
- %% every executable line and, as a side effect, initiate
- %% the database
-
+ %% Extract the abstract format.
case get_abstract_code(Module, Beam) of
no_abstract_code=E ->
{error,E};
@@ -1547,7 +1563,8 @@ do_compile_beam1(Module,Beam,UserOptions) ->
Forms0 = epp:interpret_file_attribute(Code),
case find_main_filename(Forms0) of
{ok,MainFile} ->
- do_compile_beam2(Module,Beam,UserOptions,Forms0,MainFile);
+ do_compile_beam2(Module,Beam,UserOptions,
+ Forms0,MainFile,LocalOnly);
Error ->
Error
end;
@@ -1566,26 +1583,35 @@ get_abstract_code(Module, Beam) ->
Error -> Error
end.
-do_compile_beam2(Module,Beam,UserOptions,Forms0,MainFile) ->
- {Forms,Vars} = transform(Forms0, Module, MainFile),
+do_compile_beam2(Module,Beam,UserOptions,Forms0,MainFile,LocalOnly) ->
+ init_counter_mapping(Module),
+
+ %% Instrument the abstract code by inserting
+ %% calls to update the counters.
+ {Forms,Vars} = transform(Forms0, Module, MainFile, LocalOnly),
+
+ %% Create counters.
+ maybe_create_counters(Module, not LocalOnly),
%% We need to recover the source from the compilation
%% info otherwise the newly compiled module will have
%% source pointing to the current directory
SourceInfo = get_source_info(Module, Beam),
- %% Compile and load the result
+ %% Compile and load the result.
%% It's necessary to check the result of loading since it may
- %% fail, for example if Module resides in a sticky directory
- {ok, Module, Binary} = compile:forms(Forms, SourceInfo ++ UserOptions),
+ %% fail, for example if Module resides in a sticky directory.
+ Options = SourceInfo ++ UserOptions,
+ {ok, Module, Binary} = compile:forms(Forms, Options),
+
case code:load_binary(Module, ?TAG, Binary) of
{module, Module} ->
- %% Store info about all function clauses in database
+ %% Store info about all function clauses in database.
InitInfo = lists:reverse(Vars#vars.init_info),
ets:insert(?COVER_CLAUSE_TABLE, {Module, InitInfo}),
- %% Store binary code so it can be loaded on remote nodes
+ %% Store binary code so it can be loaded on remote nodes.
ets:insert(?BINARY_TABLE, {Module, Binary}),
{ok, Module};
@@ -1617,11 +1643,12 @@ get_compile_info(Module, Beam) ->
[]
end.
-transform(Code, Module, MainFile) ->
+transform(Code, Module, MainFile, LocalOnly) ->
Vars0 = #vars{module=Module},
- {ok,MungedForms,Vars} = transform_2(Code,[],Vars0,MainFile,on),
+ {ok,MungedForms0,Vars} = transform_2(Code, [], Vars0, MainFile, on),
+ MungedForms = patch_code(Module, MungedForms0, LocalOnly),
{MungedForms,Vars}.
-
+
%% Helpfunction which returns the first found file-attribute, which can
%% be interpreted as the name of the main erlang source file.
find_main_filename([{attribute,_,file,{MainFile,_}}|_]) ->
@@ -1788,19 +1815,7 @@ munge_body([Expr|Body], Vars, MungedBody, LastExprBumpLines) ->
MungedExprs1 = [MungedExpr|MungedBody1],
munge_body(Body, Vars3, MungedExprs1, NewBumps);
false ->
- ets:insert(?COVER_TABLE, {#bump{module = Vars#vars.module,
- function = Vars#vars.function,
- arity = Vars#vars.arity,
- clause = Vars#vars.clause,
- line = Line},
- 0}),
Bump = bump_call(Vars, Line),
-% Bump = {call, 0, {remote, 0, {atom,0,cover}, {atom,0,bump}},
-% [{atom, 0, Vars#vars.module},
-% {atom, 0, Vars#vars.function},
-% {integer, 0, Vars#vars.arity},
-% {integer, 0, Vars#vars.clause},
-% {integer, 0, Line}]},
Lines2 = [Line|Lines],
{MungedExpr, Vars2} = munge_expr(Expr, Vars#vars{lines=Lines2}),
NewBumps = new_bumps(Vars2, Vars),
@@ -1855,8 +1870,10 @@ maybe_fix_last_expr(MungedExprs, Vars, LastExprBumpLines) ->
last_expr_needs_fixing(Vars, LastExprBumpLines) ->
case common_elems(Vars#vars.no_bump_lines, LastExprBumpLines) of
- [Line] -> {yes, Line};
- _ -> no
+ [Line] ->
+ {yes, Line};
+ _ ->
+ no
end.
fix_last_expr([MungedExpr|MungedExprs], Line, Vars) ->
@@ -1921,9 +1938,7 @@ fix_cls([Cl | Cls], Line, Bump) ->
bumps_line(E, L) ->
try bumps_line1(E, L) catch true -> true end.
-bumps_line1({call,_,{remote,_,{atom,_,ets},{atom,_,update_counter}},
- [{atom,_,?COVER_TABLE},{tuple,_,[_,_,_,_,_,{integer,_,Line}]},_]},
- Line) ->
+bumps_line1({'BUMP',Line,_}, Line) ->
throw(true);
bumps_line1([E | Es], Line) ->
bumps_line1(E, Line),
@@ -1933,19 +1948,12 @@ bumps_line1(T, Line) when is_tuple(T) ->
bumps_line1(_, _) ->
false.
-%%% End of fix of last expression.
-
+%% Insert a place holder for the call to counters:add/3 in the
+%% abstract code.
bump_call(Vars, Line) ->
- A = erl_anno:new(0),
- {call,A,{remote,A,{atom,A,ets},{atom,A,update_counter}},
- [{atom,A,?COVER_TABLE},
- {tuple,A,[{atom,A,?BUMP_REC_NAME},
- {atom,A,Vars#vars.module},
- {atom,A,Vars#vars.function},
- {integer,A,Vars#vars.arity},
- {integer,A,Vars#vars.clause},
- {integer,A,Line}]},
- {integer,A,1}]}.
+ {'BUMP',Line,counter_index(Vars, Line)}.
+
+%%% End of fix of last expression.
munge_expr({match,Line,ExprL,ExprR}, Vars) ->
{MungedExprL, Vars2} = munge_expr(ExprL, Vars),
@@ -2105,6 +2113,159 @@ subtract(L1, L2) ->
common_elems(L1, L2) ->
[E || E <- L1, lists:member(E, L2)].
+%%%--Counters------------------------------------------------------------
+
+init_counter_mapping(Mod) ->
+ true = ets:insert_new(?COVER_MAPPING_TABLE, {Mod,0}),
+ ok.
+
+counter_index(Vars, Line) ->
+ #vars{module=Mod,function=F,arity=A,clause=C} = Vars,
+ Key = #bump{module=Mod,function=F,arity=A,
+ clause=C,line=Line},
+ case ets:lookup(?COVER_MAPPING_TABLE, Key) of
+ [] ->
+ Index = ets:update_counter(?COVER_MAPPING_TABLE,
+ Mod, {2,1}),
+ true = ets:insert(?COVER_MAPPING_TABLE, {Key,Index}),
+ Index;
+ [{Key,Index}] ->
+ Index
+ end.
+
+%% Create the counter array and store as a persistent term.
+maybe_create_counters(Mod, true) ->
+ Cref = create_counters(Mod),
+ Key = {?MODULE,Mod},
+ persistent_term:put(Key, Cref),
+ ok;
+maybe_create_counters(_Mod, false) ->
+ ok.
+
+create_counters(Mod) ->
+ Size0 = ets:lookup_element(?COVER_MAPPING_TABLE, Mod, 2),
+ Size = max(1, Size0), %Size must not be 0.
+ Cref = counters:new(Size, [write_concurrency]),
+ ets:insert(?COVER_MAPPING_TABLE, {{counters,Mod},Cref}),
+ Cref.
+
+patch_code(Mod, Forms, false) ->
+ A = erl_anno:new(0),
+ AbstrKey = {tuple,A,[{atom,A,?MODULE},{atom,A,Mod}]},
+ patch_code1(Forms, {distributed,AbstrKey});
+patch_code(Mod, Forms, true) ->
+ Cref = create_counters(Mod),
+ AbstrCref = cid_to_abstract(Cref),
+ patch_code1(Forms, {local_only,AbstrCref}).
+
+%% Go through the abstract code and replace 'BUMP' forms
+%% with the actual code to increment the counters.
+patch_code1({'BUMP',_Line,Index}, {distributed,AbstrKey}) ->
+ %% Replace with counters:add(persistent_term:get(Key), Index, 1).
+ %% This code will work on any node.
+ A = element(2, AbstrKey),
+ GetCref = {call,A,{remote,A,{atom,A,persistent_term},{atom,A,get}},
+ [AbstrKey]},
+ {call,A,{remote,A,{atom,A,counters},{atom,A,add}},
+ [GetCref,{integer,A,Index},{integer,A,1}]};
+patch_code1({'BUMP',_Line,Index}, {local_only,AbstrCref}) ->
+ %% Replace with counters:add(Cref, Index, 1). This code
+ %% will only work on the local node.
+ A = element(2, AbstrCref),
+ {call,A,{remote,A,{atom,A,counters},{atom,A,add}},
+ [AbstrCref,{integer,A,Index},{integer,A,1}]};
+patch_code1({clauses,Cs}, Key) ->
+ {clauses,[patch_code1(El, Key) || El <- Cs]};
+patch_code1([_|_]=List, Key) ->
+ [patch_code1(El, Key) || El <- List];
+patch_code1(Tuple, Key) when tuple_size(Tuple) >= 3 ->
+ Acc = [element(2, Tuple),element(1, Tuple)],
+ patch_code_tuple(3, tuple_size(Tuple), Tuple, Key, Acc);
+patch_code1(Other, _Key) ->
+ Other.
+
+patch_code_tuple(I, Size, Tuple, Key, Acc) when I =< Size ->
+ El = patch_code1(element(I, Tuple), Key),
+ patch_code_tuple(I + 1, Size, Tuple, Key, [El|Acc]);
+patch_code_tuple(_I, _Size, _Tuple, _Key, Acc) ->
+ list_to_tuple(lists:reverse(Acc)).
+
+%% Don't try this at home! Assumes knowledge of the internal
+%% representation of a counter ref.
+cid_to_abstract(Cref0) ->
+ A = erl_anno:new(0),
+ %% Disable dialyzer warning for breaking opacity.
+ Cref = binary_to_term(term_to_binary(Cref0)),
+ {write_concurrency,Ref} = Cref,
+ {tuple,A,[{atom,A,write_concurrency},{integer,A,Ref}]}.
+
+%% Called on the remote node. Collect and send counters to
+%% the main node. Also zero the counters.
+send_counters(Mod, CollectorPid) ->
+ Process = fun(Chunk) -> send_chunk(CollectorPid, Chunk) end,
+ move_counters(Mod, Process).
+
+%% Called on the main node. Collect the counters and consolidate
+%% them into the collection table. Also zero the counters.
+move_counters(Mod) ->
+ move_counters(Mod, fun insert_in_collection_table/1).
+
+move_counters(Mod, Process) ->
+ Pattern = {#bump{module=Mod,_='_'},'_'},
+ Matches = ets:match_object(?COVER_MAPPING_TABLE, Pattern, ?CHUNK_SIZE),
+ Cref = get_counters_ref(Mod),
+ move_counters1(Matches, Cref, Process).
+
+move_counters1({Mappings,Continuation}, Cref, Process) ->
+ Move = fun({Key,Index}) ->
+ Count = counters:get(Cref, Index),
+ ok = counters:sub(Cref, Index, Count),
+ {Key,Count}
+ end,
+ Process(lists:map(Move, Mappings)),
+ move_counters1(ets:match_object(Continuation), Cref, Process);
+move_counters1('$end_of_table', _Cref, _Process) ->
+ ok.
+
+counters_mapping_table(Mod) ->
+ Mapping = counters_mapping(Mod),
+ Cref = get_counters_ref(Mod),
+ #{size:=Size} = counters:info(Cref),
+ [{Mod,Size}|Mapping].
+
+get_counters_ref(Mod) ->
+ ets:lookup_element(?COVER_MAPPING_TABLE, {counters,Mod}, 2).
+
+counters_mapping(Mod) ->
+ Pattern = {#bump{module=Mod,_='_'},'_'},
+ ets:match_object(?COVER_MAPPING_TABLE, Pattern).
+
+clear_counters(Mod) ->
+ _ = persistent_term:erase({?MODULE,Mod}),
+ ets:delete(?COVER_MAPPING_TABLE, Mod),
+ Pattern = {#bump{module=Mod,_='_'},'_'},
+ _ = ets:match_delete(?COVER_MAPPING_TABLE, Pattern),
+ ok.
+
+%% Reset counters (set counters to 0).
+reset_counters(Mod) ->
+ Pattern = {#bump{module=Mod,_='_'},'$1'},
+ MatchSpec = [{Pattern,[],['$1']}],
+ Matches = ets:select(?COVER_MAPPING_TABLE,
+ MatchSpec, ?CHUNK_SIZE),
+ Cref = get_counters_ref(Mod),
+ reset_counters1(Matches, Cref).
+
+reset_counters1({Indices,Continuation}, Cref) ->
+ _ = [counters:put(Cref, N, 0) || N <- Indices],
+ reset_counters1(ets:select(Continuation), Cref);
+reset_counters1('$end_of_table', _Cref) ->
+ ok.
+
+delete_all_counters() ->
+ _ = [persistent_term:erase(Key) || {?MODULE,_}=Key <- persistent_term:get()],
+ ok.
+
%%%--Analysis------------------------------------------------------------
%% Collect data for all modules
@@ -2140,20 +2301,7 @@ collect(Module,Clauses,Nodes) ->
%% ?COLLECTION_TABLE. Resetting data in ?COVER_TABLE
move_modules({Module,Clauses}) ->
ets:insert(?COLLECTION_CLAUSE_TABLE,{Module,Clauses}),
- Pattern = {#bump{module=Module, _='_'}, '_'},
- MatchSpec = [{Pattern,[],['$_']}],
- Match = ets:select(?COVER_TABLE,MatchSpec,?CHUNK_SIZE),
- do_move_module(Match).
-
-do_move_module({Bumps,Continuation}) ->
- lists:foreach(fun({Key,Val}) ->
- ets:insert(?COVER_TABLE, {Key,0}),
- insert_in_collection_table(Key,Val)
- end,
- Bumps),
- do_move_module(ets:select(Continuation));
-do_move_module('$end_of_table') ->
- ok.
+ move_counters(Module).
%% Given a .beam file, find the .erl file. Look first in same directory as
%% the .beam file, then in ../src, then in compile info.
@@ -2709,7 +2857,7 @@ get_term(Fd) ->
%% Reset main node and all remote nodes
do_reset_main_node(Module,Nodes) ->
- do_reset(Module),
+ reset_counters(Module),
do_reset_collection_table(Module),
remote_reset(Module,Nodes).
@@ -2717,27 +2865,9 @@ do_reset_collection_table(Module) ->
ets:delete(?COLLECTION_CLAUSE_TABLE,Module),
ets:match_delete(?COLLECTION_TABLE, {#bump{module=Module},'_'}).
-%% do_reset(Module) -> ok
-%% The reset is done on ?CHUNK_SIZE number of bumps to avoid building
-%% long lists in the case of very large modules
-do_reset(Module) ->
- Pattern = {#bump{module=Module, _='_'}, '$1'},
- MatchSpec = [{Pattern,[{'=/=','$1',0}],['$_']}],
- Match = ets:select(?COVER_TABLE,MatchSpec,?CHUNK_SIZE),
- do_reset2(Match).
-
-do_reset2({Bumps,Continuation}) ->
- lists:foreach(fun({Bump,_N}) ->
- ets:insert(?COVER_TABLE, {Bump,0})
- end,
- Bumps),
- do_reset2(ets:select(Continuation));
-do_reset2('$end_of_table') ->
- ok.
-
do_clear(Module) ->
ets:match_delete(?COVER_CLAUSE_TABLE, {Module,'_'}),
- ets:match_delete(?COVER_TABLE, {#bump{module=Module},'_'}),
+ clear_counters(Module),
case lists:member(?COLLECTION_TABLE, ets:all()) of
true ->
%% We're on the main node
diff --git a/lib/tools/src/tools.app.src b/lib/tools/src/tools.app.src
index f8c6aa22cb..f0e0fc4bec 100644
--- a/lib/tools/src/tools.app.src
+++ b/lib/tools/src/tools.app.src
@@ -21,11 +21,13 @@
[{description, "DEVTOOLS CXC 138 16"},
{vsn, "%VSN%"},
{modules, [cover,
+ cprof,
eprof,
fprof,
instrument,
lcnt,
make,
+ tags,
xref,
xref_base,
xref_compiler,
diff --git a/lib/tools/test/Makefile b/lib/tools/test/Makefile
index 2b7b17afb3..7a0a941ccc 100644
--- a/lib/tools/test/Makefile
+++ b/lib/tools/test/Makefile
@@ -32,6 +32,7 @@ MODULES = \
make_SUITE \
tools_SUITE \
xref_SUITE \
+ prof_bench_SUITE \
ignore_cores
ERL_FILES= $(MODULES:%=%.erl)
@@ -41,7 +42,7 @@ INSTALL_PROGS= $(TARGET_FILES)
EMAKEFILE=Emakefile
-SPEC_FILES= tools.spec
+SPEC_FILES= tools.spec tools_bench.spec
COVER_FILE = tools.cover
# ----------------------------------------------------
diff --git a/lib/tools/test/cover_SUITE.erl b/lib/tools/test/cover_SUITE.erl
index 161b0105b9..462767f430 100644
--- a/lib/tools/test/cover_SUITE.erl
+++ b/lib/tools/test/cover_SUITE.erl
@@ -24,7 +24,8 @@
-include_lib("common_test/include/ct.hrl").
suite() ->
- [{ct_hooks,[ts_install_cth]}].
+ [{ct_hooks,[ts_install_cth]},
+ {timetrap,{minutes,5}}].
all() ->
NoStartStop = [eif,otp_5305,otp_5418,otp_7095,otp_8273,
@@ -35,7 +36,8 @@ all() ->
distribution, reconnect, die_and_reconnect,
dont_reconnect_after_stop, stop_node_after_disconnect,
export_import, otp_5031, otp_6115,
- otp_8270, otp_10979_hanging_node, otp_14817],
+ otp_8270, otp_10979_hanging_node, otp_14817,
+ local_only, startup_race],
case whereis(cover_server) of
undefined ->
[coverage,StartStop ++ NoStartStop];
@@ -1742,6 +1744,65 @@ otp_13289(Config) ->
ok = file:delete(File),
ok.
+local_only(Config) ->
+ ok = file:set_cwd(proplists:get_value(data_dir, Config)),
+
+ %% Trying restricting to local nodes too late.
+ cover:start(),
+ {ok,a} = cover:compile(a),
+ [a] = cover:modules(),
+ {error,too_late} = cover:local_only(),
+ cover:stop(),
+
+ %% Now test local only mode.
+ cover:start(),
+ ok = cover:local_only(),
+ [] = cover:modules(),
+ {ok,a} = cover:compile(a),
+ [a] = cover:modules(),
+ done = a:start(5),
+ {ok, {a,{17,2}}} = cover:analyse(a, coverage, module),
+ {ok, [{{a,exit_kalle,0},{1,0}},
+ {{a,loop,3},{5,1}},
+ {{a,pong,1},{1,0}},
+ {{a,start,1},{6,0}},
+ {{a,stop,1},{0,1}},
+ {{a,trycatch,1},{4,0}}]} =
+ cover:analyse(a, coverage, function),
+
+ %% Make sure that it is not possible to run cover on
+ %% slave nodes.
+ {ok,Name} = test_server:start_node(?FUNCTION_NAME, slave, []),
+ {error,local_only} = cover:start([Name]),
+ test_server:stop_node(Name),
+ ok.
+
+%% ERL-943; We should not crash on startup when multiple servers race to
+%% register the server name.
+startup_race(Config) when is_list(Config) ->
+ PidRefs = [spawn_monitor(fun() ->
+ case cover:start() of
+ {error, {already_started, _Pid}} ->
+ ok;
+ {ok, _Pid} ->
+ ok
+ end
+ end) || _<- lists:seq(1,8)],
+ startup_race_1(PidRefs).
+
+startup_race_1([{Pid, Ref} | PidRefs]) ->
+ receive
+ {'DOWN', Ref, process, Pid, normal} ->
+ startup_race_1(PidRefs);
+ {'DOWN', Ref, process, Pid, _Other} ->
+ ct:fail("Cover server crashed on startup.")
+ after 5000 ->
+ ct:fail("Timed out.")
+ end;
+startup_race_1([]) ->
+ cover:stop(),
+ ok.
+
%%--Auxiliary------------------------------------------------------------
analyse_expr(Expr, Config) ->
diff --git a/lib/tools/test/emacs_SUITE.erl b/lib/tools/test/emacs_SUITE.erl
index a6d43d1816..73270e6ed6 100644
--- a/lib/tools/test/emacs_SUITE.erl
+++ b/lib/tools/test/emacs_SUITE.erl
@@ -70,19 +70,20 @@ bif_highlight(Config) ->
check_bif_highlight(Bin, Tag, Compare) ->
- [_H,IntMatch,_T] =
+ [_H,Match,_T] =
re:split(Bin,<<"defvar ",Tag/binary,
"[^(]*\\(([^)]*)">>,[]),
- EmacsIntBifs = [list_to_atom(S) ||
- S <- string:tokens(binary_to_list(IntMatch)," '\"\n")],
+ EmacsBifs = [list_to_atom(S) ||
+ S <- string:tokens(binary_to_list(Match)," '\"\n")],
- ct:log("Emacs ~p",[EmacsIntBifs]),
- ct:log("Int ~p",[Compare]),
+ ct:log("Comparing ~s", [Tag]),
+ ct:log("Emacs ~p",[EmacsBifs]),
+ ct:log("Erlang ~p",[Compare]),
- ct:log("Diff1 ~p",[Compare -- EmacsIntBifs]),
- ct:log("Diff2 ~p",[EmacsIntBifs -- Compare]),
- [] = Compare -- EmacsIntBifs,
- [] = EmacsIntBifs -- Compare.
+ ct:log("Only in Erlang ~p",[Compare -- EmacsBifs]),
+ ct:log("Only in Emacs ~p",[EmacsBifs -- Compare]),
+ [] = Compare -- EmacsBifs,
+ [] = EmacsBifs -- Compare.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -118,7 +119,7 @@ compile_and_load(_Config) ->
false -> " "
end,
emacs([Pedantic,
- " -f batch-byte-compile ",filename:join(Dir, File)]),
+ " -f batch-byte-compile ", dquote(filename:join(Dir, File))]),
true
end,
lists:foreach(Compile, Files),
@@ -143,6 +144,10 @@ tests_compiled(_Config) ->
ok
end.
+
+dquote(Str) ->
+ "\"" ++ Str ++ "\"".
+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
indent(Config) ->
@@ -188,7 +193,9 @@ diff(Orig, File) ->
end.
emacs_version_ok(AcceptVer) ->
- case os:cmd("emacs --version | head -1") of
+ VersionLine = os:cmd("emacs --version | head -1"),
+ io:format("~s~n", [VersionLine]),
+ case VersionLine of
"GNU Emacs " ++ Ver ->
case string:to_float(Ver) of
{Vsn, _} when Vsn >= AcceptVer ->
@@ -204,14 +211,14 @@ emacs_version_ok(AcceptVer) ->
emacs(EmacsCmds) when is_list(EmacsCmds) ->
Cmd = ["emacs ",
"--batch --quick ",
- "--directory ", emacs_dir(), " ",
+ "--directory ", dquote(emacs_dir()), " ",
"--eval \"(require 'erlang-start)\" "
| EmacsCmds],
Res0 = os:cmd(Cmd ++ " ; echo $?"),
Rows = string:lexemes(Res0, ["\r\n", $\n]),
Res = lists:last(Rows),
Output = string:join(lists:droplast(Rows), "\n"),
- io:format("Cmd ~s:~n => ~s ~ts~n", [Cmd, Res, Output]),
+ io:format("Cmd ~ts:~n => ~s ~ts~n", [Cmd, Res, Output]),
"0" = Res,
Output.
diff --git a/lib/tools/test/instrument_SUITE.erl b/lib/tools/test/instrument_SUITE.erl
index 8c521b2e1a..f474669836 100644
--- a/lib/tools/test/instrument_SUITE.erl
+++ b/lib/tools/test/instrument_SUITE.erl
@@ -77,6 +77,8 @@ allocations_ramv(Config) when is_list(Config) ->
verify_allocations_disabled(_AllocType, Result) ->
verify_allocations_disabled(Result).
+verify_allocations_disabled({ok, {_HistStart, _UnscannedBytes, Allocs}}) ->
+ true = Allocs =:= #{};
verify_allocations_disabled({error, not_enabled}) ->
ok.
@@ -91,6 +93,13 @@ verify_allocations_enabled(_AllocType, Result) ->
verify_allocations_enabled({ok, {_HistStart, _UnscannedBytes, Allocs}}) ->
true = Allocs =/= #{}.
+verify_allocations_output(#{}, {ok, {_, _, Allocs}}) when Allocs =:= #{} ->
+ %% This happens when the allocator is enabled but tagging is disabled. If
+ %% there's an error that causes Allocs to always be empty when enabled it
+ %% will be caught by verify_allocations_enabled.
+ ok;
+verify_allocations_output(#{}, {error, not_enabled}) ->
+ ok;
verify_allocations_output(#{ histogram_start := HistStart,
histogram_width := HistWidth },
{ok, {HistStart, _UnscannedBytes, ByOrigin}}) ->
@@ -124,8 +133,6 @@ verify_allocations_output(#{ histogram_start := HistStart,
[BlockCount, GenTotalBlockCount])
end,
- ok;
-verify_allocations_output(#{}, {error, not_enabled}) ->
ok.
%% %% %% %% %% %%
@@ -214,7 +221,8 @@ verify_carriers_output(#{ histogram_start := HistStart,
ct:fail("Carrier count is ~p, expected at least ~p (SBC).",
[CarrierCount, GenSBCCount]);
CarrierCount >= GenSBCCount ->
- ok
+ ct:pal("Found ~p carriers, required at least ~p (SBC)." ,
+ [CarrierCount, GenSBCCount])
end,
ok;
@@ -252,13 +260,18 @@ test_format(Options0, Gather, Verify) ->
test_abort(Gather) ->
%% There's no way for us to tell whether this actually aborted or ran to
%% completion, but it might catch a few segfaults.
+ %% This testcase is mostly useful when run in an debug emulator as it needs
+ %% the modified reduction count to trigger the odd trap scenarios
Runner = self(),
Ref = make_ref(),
spawn_opt(fun() ->
- [Gather({Type, SchedId, 1, 1, Ref}) ||
- Type <- erlang:system_info(alloc_util_allocators),
- SchedId <- lists:seq(0, erlang:system_info(schedulers))],
- Runner ! Ref
+ [begin
+ Ref2 = make_ref(),
+ [Gather({Type, SchedId, 1, 1, Ref2}) ||
+ Type <- erlang:system_info(alloc_util_allocators),
+ SchedId <- lists:seq(0, erlang:system_info(schedulers))]
+ end || _ <- lists:seq(1,100)],
+ Runner ! Ref
end, [{priority, max}]),
receive
Ref -> ok
@@ -292,9 +305,19 @@ start_slave(Args) ->
MicroSecs = erlang:monotonic_time(),
Name = "instr" ++ integer_to_list(MicroSecs),
Pa = filename:dirname(code:which(?MODULE)),
- {ok, Node} = test_server:start_node(list_to_atom(Name),
- slave,
- [{args, "-pa " ++ Pa ++ " " ++ Args}]),
+
+ %% We pass arguments through ZFLAGS as the nightly tests rotate
+ %% +Meamax/+Meamin which breaks the _enabled and _disabled tests unless
+ %% overridden.
+ ZFlags = os:getenv("ERL_ZFLAGS", ""),
+ {ok, Node} = try
+ os:putenv("ERL_ZFLAGS", ZFlags ++ [" " | Args]),
+ test_server:start_node(list_to_atom(Name),
+ slave,
+ [{args, "-pa " ++ Pa}])
+ after
+ os:putenv("ERL_ZFLAGS", ZFlags)
+ end,
Node.
generate_test_blocks() ->
@@ -309,8 +332,9 @@ generate_test_blocks() ->
MBCs = [<<I, 0:64/unit:8>> ||
I <- lists:seq(1, ?GENERATED_MBC_BLOCK_COUNT)],
Runner ! Ref,
- receive after infinity -> ok end,
- unreachable ! {SBCs, MBCs}
+ receive
+ gurka -> gaffel ! {SBCs, MBCs}
+ end
end),
receive
Ref -> ok
diff --git a/lib/tools/test/prof_bench_SUITE.erl b/lib/tools/test/prof_bench_SUITE.erl
new file mode 100644
index 0000000000..50d0ba9cd9
--- /dev/null
+++ b/lib/tools/test/prof_bench_SUITE.erl
@@ -0,0 +1,126 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-2017. All Rights Reserved.
+%%
+%% 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.
+%%
+%% %CopyrightEnd%
+%%
+-module(prof_bench_SUITE).
+
+-include_lib("common_test/include/ct_event.hrl").
+
+%% Test server framework exports
+-export([all/0, suite/0, init_per_suite/1, end_per_suite/1]).
+
+-export([overhead/1]).
+
+%%%---------------------------------------------------------------------
+%%% Test suites
+%%%---------------------------------------------------------------------
+
+
+suite() ->
+ [{timetrap,{minutes,10}}].
+
+all() ->
+ [overhead].
+
+init_per_suite(Config) ->
+ case {test_server:is_native(fprof_SUITE) or
+ (lists:any(fun(M) -> test_server:is_native(M) end, modules())) or
+ (whereis(cover_server) =/= undefined),
+ erlang:system_info(wordsize)}
+ of
+ {true, _} -> {skip, "Native or cover code"};
+ {_, 4} -> {skip, "Can't run on 32-bit as files will be large"};
+ {false, 8} -> Config
+ end.
+
+end_per_suite(Config) ->
+ LogFile = filename:join(proplists:get_value(priv_dir, Config), "fprof.trace"),
+ file:delete(LogFile),
+ ok.
+
+%%%---------------------------------------------------------------------
+
+%% ct:run_test([{suite, prof_bench_SUITE}]).
+overhead(Config) ->
+ LogFile = filename:join(proplists:get_value(priv_dir, Config), "fprof.trace"),
+ SofsCopy = filename:join(proplists:get_value(data_dir, Config), "sofs_copy.erl"),
+ TC = fun() -> compile:file(SofsCopy, [binary]) end,
+ _Warmup = timer:tc(TC),
+
+ {NormTime,{ok, sofs_copy, _}} = timer:tc(TC),
+ {FProfTime,{ok,sofs_copy,_}} = fprof:apply(timer, tc, [TC], [{file, LogFile}]),
+ ct:pal("FProf: ~p Norm: ~p Ratio: ~p",[FProfTime, NormTime, NormTime / FProfTime * 100]),
+ {ok,{EProfTime,{ok,sofs_copy,_}}} = eprof:profile([], timer, tc, [TC]),
+ ct:pal("EProf: ~p Norm: ~p Ratio: ~p",[EProfTime, NormTime, NormTime / EProfTime * 100]),
+ {CProfTime,{ok,sofs_copy,_}} = cprof_apply(timer, tc, [TC]),
+ ct:pal("CProf: ~p Norm: ~p Ratio: ~p",[CProfTime, NormTime, NormTime / CProfTime * 100]),
+ {CoverTime,{ok,sofs_copy,_}} = cover_apply(timer, tc, [TC]),
+ ct:pal("Cover: ~p Norm: ~p Ratio: ~p",[CoverTime, NormTime, NormTime / CoverTime * 100]),
+
+ ct_event:notify(#event{name = benchmark_data,
+ data = [{name, fprof_overhead},
+ {value, NormTime / FProfTime * 100}]}),
+ ct_event:notify(#event{name = benchmark_data,
+ data = [{name, eprof_overhead},
+ {value, NormTime / EProfTime * 100}]}),
+ ct_event:notify(#event{name = benchmark_data,
+ data = [{name, cprof_overhead},
+ {value, NormTime / CProfTime * 100}]}),
+ ct_event:notify(#event{name = benchmark_data,
+ data = [{name, cover_overhead},
+ {value, NormTime / CoverTime * 100}]}).
+
+%% overhead(Config) ->
+%% LogFile = filename:join(proplists:get_value(priv_dir, Config), "fprof.trace"),
+%% SofsCopy = filename:join(proplists:get_value(data_dir, Config), "sofs_copy.erl"),
+%% TC = fun() -> compile:file(SofsCopy, [binary]) end,
+%% _Warmup = timer:tc(TC),
+
+%% [{ok,{EProfTime,{ok,sofs_copy,_}}} = eprof:profile([], timer, tc, [TC])
+%% || _ <- lists:seq(1,10)],
+%% %% [fprof:apply(timer, tc, [TC], [{file, LogFile}]) || _ <- lists:seq(1,10)],
+%% {FProfTime,{ok,sofs_copy,_}} = fprof:apply(timer, tc, [TC], [{file, LogFile}]),
+%% {NormTime,{ok, sofs_copy, _}} = timer:tc(TC),
+
+ %% ct:pal("FProf: ~p Norm: ~p Ratio: ~p",[FProfTime, NormTime, FProfTime / NormTime]).
+
+cprof_apply(M, F, A) ->
+ cprof:start(),
+ Res = apply(M, F, A),
+ cprof:stop(),
+ Res.
+
+cover_apply(M, F, A) ->
+ cover:start(),
+ catch cover:local_only(),
+ Modules = modules(),
+ [code:unstick_mod(Mod) || Mod <- Modules],
+ cover:compile_beam(Modules),
+ [code:stick_mod(Mod) || Mod <- Modules],
+ Res = apply(M, F, A),
+ cover:stop(),
+ Res.
+
+modules() ->
+ application:load(compiler),
+ {ok, CompilerModules} = application:get_key(compiler, modules),
+ %% Only cover compile a subset of the stdlib modules
+ StdlibModules = [erl_parse, erl_expand_records, erl_lint, gb_trees, gb_sets, sofs,
+ beam_lib, dict, epp, erl_anno, erl_bits,
+ orddict, ordsets, sets, string, unicode, unicode_util],
+ CompilerModules ++ StdlibModules.
diff --git a/lib/tools/test/prof_bench_SUITE_data/sofs_copy.erl b/lib/tools/test/prof_bench_SUITE_data/sofs_copy.erl
new file mode 100644
index 0000000000..2a9b19177e
--- /dev/null
+++ b/lib/tools/test/prof_bench_SUITE_data/sofs_copy.erl
@@ -0,0 +1,2809 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2001-2017. All Rights Reserved.
+%%
+%% 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.
+%%
+%% %CopyrightEnd%
+%%
+-module(sofs_copy).
+
+-export([from_term/1, from_term/2, from_external/2, empty_set/0,
+ is_type/1, set/1, set/2, from_sets/1, relation/1, relation/2,
+ a_function/1, a_function/2, family/1, family/2,
+ to_external/1, type/1, to_sets/1, no_elements/1,
+ specification/2, union/2, intersection/2, difference/2,
+ symdiff/2, symmetric_partition/2, product/1, product/2,
+ constant_function/2, is_equal/2, is_subset/2, is_sofs_set/1,
+ is_set/1, is_empty_set/1, is_disjoint/2]).
+
+-export([union/1, intersection/1, canonical_relation/1]).
+
+-export([relation_to_family/1, domain/1, range/1, field/1,
+ relative_product/1, relative_product/2, relative_product1/2,
+ converse/1, image/2, inverse_image/2, strict_relation/1,
+ weak_relation/1, extension/3, is_a_function/1]).
+
+-export([composite/2, inverse/1]).
+
+-export([restriction/2, restriction/3, drestriction/2, drestriction/3,
+ substitution/2, projection/2, partition/1, partition/2,
+ partition/3, multiple_relative_product/2, join/4]).
+
+-export([family_to_relation/1, family_specification/2,
+ union_of_family/1, intersection_of_family/1,
+ family_union/1, family_intersection/1,
+ family_domain/1, family_range/1, family_field/1,
+ family_union/2, family_intersection/2, family_difference/2,
+ partition_family/2, family_projection/2]).
+
+-export([family_to_digraph/1, family_to_digraph/2,
+ digraph_to_family/1, digraph_to_family/2]).
+
+%% Shorter names of some functions.
+-export([fam2rel/1, rel2fam/1]).
+
+-import(lists,
+ [any/2, append/1, flatten/1, foreach/2,
+ keysort/2, last/1, map/2, mapfoldl/3, member/2, merge/2,
+ reverse/1, reverse/2, sort/1, umerge/1, umerge/2, usort/1]).
+
+-compile({inline, [{family_to_relation,1}, {relation_to_family,1}]}).
+
+-compile({inline, [{rel,2},{a_func,2},{fam,2},{term2set,2}]}).
+
+-compile({inline, [{external_fun,1},{element_type,1}]}).
+
+-compile({inline,
+ [{unify_types,2}, {match_types,2},
+ {test_rel,3}, {symdiff,3},
+ {subst,3}]}).
+
+-compile({inline, [{fam_binop,3}]}).
+
+%% Nope, no is_member, del_member or add_member.
+%%
+%% See also "Naive Set Theory" by Paul R. Halmos.
+%%
+%% By convention, erlang:error/1 is called from exported functions.
+
+-define(TAG, 'Set').
+-define(ORDTAG, 'OrdSet').
+
+-record(?TAG, {data = [] :: list(), type = type :: term()}).
+-record(?ORDTAG, {orddata = {} :: tuple() | atom(),
+ ordtype = type :: term()}).
+
+-define(LIST(S), (S)#?TAG.data).
+-define(TYPE(S), (S)#?TAG.type).
+-define(SET(L, T), #?TAG{data = L, type = T}).
+-define(IS_SET(S), is_record(S, ?TAG)).
+-define(IS_UNTYPED_SET(S), ?TYPE(S) =:= ?ANYTYPE).
+
+%% Ordered sets and atoms:
+-define(ORDDATA(S), (S)#?ORDTAG.orddata).
+-define(ORDTYPE(S), (S)#?ORDTAG.ordtype).
+-define(ORDSET(L, T), #?ORDTAG{orddata = L, ordtype = T}).
+-define(IS_ORDSET(S), is_record(S, ?ORDTAG)).
+-define(ATOM_TYPE, atom).
+-define(IS_ATOM_TYPE(T), is_atom(T)). % true for ?ANYTYPE...
+
+%% When IS_SET is true:
+-define(ANYTYPE, '_').
+-define(BINREL(X, Y), {X, Y}).
+-define(IS_RELATION(R), is_tuple(R)).
+-define(REL_ARITY(R), tuple_size(R)).
+-define(REL_TYPE(I, R), element(I, R)).
+-define(SET_OF(X), [X]).
+-define(IS_SET_OF(X), is_list(X)).
+-define(FAMILY(X, Y), ?BINREL(X, ?SET_OF(Y))).
+
+-export_type([anyset/0, binary_relation/0, external_set/0, a_function/0,
+ family/0, relation/0, set_of_sets/0, set_fun/0, spec_fun/0,
+ type/0]).
+-export_type([ordset/0, a_set/0]).
+
+-type(anyset() :: ordset() | a_set()).
+-type(binary_relation() :: relation()).
+-type(external_set() :: term()).
+-type(a_function() :: relation()).
+-type(family() :: a_function()).
+-opaque(ordset() :: #?ORDTAG{}).
+-type(relation() :: a_set()).
+-opaque(a_set() :: #?TAG{}).
+-type(set_of_sets() :: a_set()).
+-type(set_fun() :: pos_integer()
+ | {external, fun((external_set()) -> external_set())}
+ | fun((anyset()) -> anyset())).
+-type(spec_fun() :: {external, fun((external_set()) -> boolean())}
+ | fun((anyset()) -> boolean())).
+-type(type() :: term()).
+
+-type(tuple_of(_T) :: tuple()).
+
+%%
+%% Exported functions
+%%
+
+%%%
+%%% Create sets
+%%%
+
+-spec(from_term(Term) -> AnySet when
+ AnySet :: anyset(),
+ Term :: term()).
+from_term(T) ->
+ Type = case T of
+ _ when is_list(T) -> [?ANYTYPE];
+ _ -> ?ANYTYPE
+ end,
+ try setify(T, Type)
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(from_term(Term, Type) -> AnySet when
+ AnySet :: anyset(),
+ Term :: term(),
+ Type :: type()).
+from_term(L, T) ->
+ case is_type(T) of
+ true ->
+ try setify(L, T)
+ catch _:_ -> erlang:error(badarg)
+ end;
+ false ->
+ erlang:error(badarg)
+ end.
+
+-spec(from_external(ExternalSet, Type) -> AnySet when
+ ExternalSet :: external_set(),
+ AnySet :: anyset(),
+ Type :: type()).
+from_external(L, ?SET_OF(Type)) ->
+ ?SET(L, Type);
+from_external(T, Type) ->
+ ?ORDSET(T, Type).
+
+-spec(empty_set() -> Set when
+ Set :: a_set()).
+empty_set() ->
+ ?SET([], ?ANYTYPE).
+
+-spec(is_type(Term) -> Bool when
+ Bool :: boolean(),
+ Term :: term()).
+is_type(Atom) when ?IS_ATOM_TYPE(Atom), Atom =/= ?ANYTYPE ->
+ true;
+is_type(?SET_OF(T)) ->
+ is_element_type(T);
+is_type(T) when tuple_size(T) > 0 ->
+ is_types(tuple_size(T), T);
+is_type(_T) ->
+ false.
+
+-spec(set(Terms) -> Set when
+ Set :: a_set(),
+ Terms :: [term()]).
+set(L) ->
+ try usort(L) of
+ SL -> ?SET(SL, ?ATOM_TYPE)
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(set(Terms, Type) -> Set when
+ Set :: a_set(),
+ Terms :: [term()],
+ Type :: type()).
+set(L, ?SET_OF(Type)) when ?IS_ATOM_TYPE(Type), Type =/= ?ANYTYPE ->
+ try usort(L) of
+ SL -> ?SET(SL, Type)
+ catch _:_ -> erlang:error(badarg)
+ end;
+set(L, ?SET_OF(_) = T) ->
+ try setify(L, T)
+ catch _:_ -> erlang:error(badarg)
+ end;
+set(_, _) ->
+ erlang:error(badarg).
+
+-spec(from_sets(ListOfSets) -> Set when
+ Set :: a_set(),
+ ListOfSets :: [anyset()];
+ (TupleOfSets) -> Ordset when
+ Ordset :: ordset(),
+ TupleOfSets :: tuple_of(anyset())).
+from_sets(Ss) when is_list(Ss) ->
+ case set_of_sets(Ss, [], ?ANYTYPE) of
+ {error, Error} ->
+ erlang:error(Error);
+ Set ->
+ Set
+ end;
+from_sets(Tuple) when is_tuple(Tuple) ->
+ case ordset_of_sets(tuple_to_list(Tuple), [], []) of
+ error ->
+ erlang:error(badarg);
+ Set ->
+ Set
+ end;
+from_sets(_) ->
+ erlang:error(badarg).
+
+-spec(relation(Tuples) -> Relation when
+ Relation :: relation(),
+ Tuples :: [tuple()]).
+relation([]) ->
+ ?SET([], ?BINREL(?ATOM_TYPE, ?ATOM_TYPE));
+relation(Ts = [T | _]) when is_tuple(T) ->
+ try rel(Ts, tuple_size(T))
+ catch _:_ -> erlang:error(badarg)
+ end;
+relation(_) ->
+ erlang:error(badarg).
+
+-spec(relation(Tuples, Type) -> Relation when
+ N :: integer(),
+ Type :: N | type(),
+ Relation :: relation(),
+ Tuples :: [tuple()]).
+relation(Ts, TS) ->
+ try rel(Ts, TS)
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(a_function(Tuples) -> Function when
+ Function :: a_function(),
+ Tuples :: [tuple()]).
+a_function(Ts) ->
+ try func(Ts, ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)) of
+ Bad when is_atom(Bad) ->
+ erlang:error(Bad);
+ Set ->
+ Set
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(a_function(Tuples, Type) -> Function when
+ Function :: a_function(),
+ Tuples :: [tuple()],
+ Type :: type()).
+a_function(Ts, T) ->
+ try a_func(Ts, T) of
+ Bad when is_atom(Bad) ->
+ erlang:error(Bad);
+ Set ->
+ Set
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(family(Tuples) -> Family when
+ Family :: family(),
+ Tuples :: [tuple()]).
+family(Ts) ->
+ try fam2(Ts, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) of
+ Bad when is_atom(Bad) ->
+ erlang:error(Bad);
+ Set ->
+ Set
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(family(Tuples, Type) -> Family when
+ Family :: family(),
+ Tuples :: [tuple()],
+ Type :: type()).
+family(Ts, T) ->
+ try fam(Ts, T) of
+ Bad when is_atom(Bad) ->
+ erlang:error(Bad);
+ Set ->
+ Set
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+%%%
+%%% Functions on sets.
+%%%
+
+-spec(to_external(AnySet) -> ExternalSet when
+ ExternalSet :: external_set(),
+ AnySet :: anyset()).
+to_external(S) when ?IS_SET(S) ->
+ ?LIST(S);
+to_external(S) when ?IS_ORDSET(S) ->
+ ?ORDDATA(S).
+
+-spec(type(AnySet) -> Type when
+ AnySet :: anyset(),
+ Type :: type()).
+type(S) when ?IS_SET(S) ->
+ ?SET_OF(?TYPE(S));
+type(S) when ?IS_ORDSET(S) ->
+ ?ORDTYPE(S).
+
+-spec(to_sets(ASet) -> Sets when
+ ASet :: a_set() | ordset(),
+ Sets :: tuple_of(AnySet) | [AnySet],
+ AnySet :: anyset()).
+to_sets(S) when ?IS_SET(S) ->
+ case ?TYPE(S) of
+ ?SET_OF(Type) -> list_of_sets(?LIST(S), Type, []);
+ Type -> list_of_ordsets(?LIST(S), Type, [])
+ end;
+to_sets(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) ->
+ tuple_of_sets(tuple_to_list(?ORDDATA(S)), tuple_to_list(?ORDTYPE(S)), []);
+to_sets(S) when ?IS_ORDSET(S) ->
+ erlang:error(badarg).
+
+-spec(no_elements(ASet) -> NoElements when
+ ASet :: a_set() | ordset(),
+ NoElements :: non_neg_integer()).
+no_elements(S) when ?IS_SET(S) ->
+ length(?LIST(S));
+no_elements(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) ->
+ tuple_size(?ORDDATA(S));
+no_elements(S) when ?IS_ORDSET(S) ->
+ erlang:error(badarg).
+
+-spec(specification(Fun, Set1) -> Set2 when
+ Fun :: spec_fun(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+specification(Fun, S) when ?IS_SET(S) ->
+ Type = ?TYPE(S),
+ R = case external_fun(Fun) of
+ false ->
+ spec(?LIST(S), Fun, element_type(Type), []);
+ XFun ->
+ specification(?LIST(S), XFun, [])
+ end,
+ case R of
+ SL when is_list(SL) ->
+ ?SET(SL, Type);
+ Bad ->
+ erlang:error(Bad)
+ end.
+
+-spec(union(Set1, Set2) -> Set3 when
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set()).
+union(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case unify_types(?TYPE(S1), ?TYPE(S2)) of
+ [] -> erlang:error(type_mismatch);
+ Type -> ?SET(umerge(?LIST(S1), ?LIST(S2)), Type)
+ end.
+
+-spec(intersection(Set1, Set2) -> Set3 when
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set()).
+intersection(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case unify_types(?TYPE(S1), ?TYPE(S2)) of
+ [] -> erlang:error(type_mismatch);
+ Type -> ?SET(intersection(?LIST(S1), ?LIST(S2), []), Type)
+ end.
+
+-spec(difference(Set1, Set2) -> Set3 when
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set()).
+difference(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case unify_types(?TYPE(S1), ?TYPE(S2)) of
+ [] -> erlang:error(type_mismatch);
+ Type -> ?SET(difference(?LIST(S1), ?LIST(S2), []), Type)
+ end.
+
+-spec(symdiff(Set1, Set2) -> Set3 when
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set()).
+symdiff(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case unify_types(?TYPE(S1), ?TYPE(S2)) of
+ [] -> erlang:error(type_mismatch);
+ Type -> ?SET(symdiff(?LIST(S1), ?LIST(S2), []), Type)
+ end.
+
+-spec(symmetric_partition(Set1, Set2) -> {Set3, Set4, Set5} when
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set(),
+ Set4 :: a_set(),
+ Set5 :: a_set()).
+symmetric_partition(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case unify_types(?TYPE(S1), ?TYPE(S2)) of
+ [] -> erlang:error(type_mismatch);
+ Type -> sympart(?LIST(S1), ?LIST(S2), [], [], [], Type)
+ end.
+
+-spec(product(Set1, Set2) -> BinRel when
+ BinRel :: binary_relation(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+product(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ if
+ ?TYPE(S1) =:= ?ANYTYPE -> S1;
+ ?TYPE(S2) =:= ?ANYTYPE -> S2;
+ true ->
+ F = fun(E) -> {0, E} end,
+ T = ?BINREL(?TYPE(S1), ?TYPE(S2)),
+ ?SET(relprod(map(F, ?LIST(S1)), map(F, ?LIST(S2))), T)
+ end.
+
+-spec(product(TupleOfSets) -> Relation when
+ Relation :: relation(),
+ TupleOfSets :: tuple_of(a_set())).
+product({S1, S2}) ->
+ product(S1, S2);
+product(T) when is_tuple(T) ->
+ Ss = tuple_to_list(T),
+ try sets_to_list(Ss) of
+ [] ->
+ erlang:error(badarg);
+ L ->
+ Type = types(Ss, []),
+ case member([], L) of
+ true ->
+ empty_set();
+ false ->
+ ?SET(reverse(prod(L, [], [])), Type)
+ end
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(constant_function(Set, AnySet) -> Function when
+ AnySet :: anyset(),
+ Function :: a_function(),
+ Set :: a_set()).
+constant_function(S, E) when ?IS_SET(S) ->
+ case {?TYPE(S), is_sofs_set(E)} of
+ {?ANYTYPE, true} -> S;
+ {Type, true} ->
+ NType = ?BINREL(Type, type(E)),
+ ?SET(constant_function(?LIST(S), to_external(E), []), NType);
+ _ -> erlang:error(badarg)
+ end;
+constant_function(S, _) when ?IS_ORDSET(S) ->
+ erlang:error(badarg).
+
+-spec(is_equal(AnySet1, AnySet2) -> Bool when
+ AnySet1 :: anyset(),
+ AnySet2 :: anyset(),
+ Bool :: boolean()).
+is_equal(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case match_types(?TYPE(S1), ?TYPE(S2)) of
+ true -> ?LIST(S1) == ?LIST(S2);
+ false -> erlang:error(type_mismatch)
+ end;
+is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_ORDSET(S2) ->
+ case match_types(?ORDTYPE(S1), ?ORDTYPE(S2)) of
+ true -> ?ORDDATA(S1) == ?ORDDATA(S2);
+ false -> erlang:error(type_mismatch)
+ end;
+is_equal(S1, S2) when ?IS_SET(S1), ?IS_ORDSET(S2) ->
+ erlang:error(type_mismatch);
+is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_SET(S2) ->
+ erlang:error(type_mismatch).
+
+-spec(is_subset(Set1, Set2) -> Bool when
+ Bool :: boolean(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+is_subset(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case match_types(?TYPE(S1), ?TYPE(S2)) of
+ true -> subset(?LIST(S1), ?LIST(S2));
+ false -> erlang:error(type_mismatch)
+ end.
+
+-spec(is_sofs_set(Term) -> Bool when
+ Bool :: boolean(),
+ Term :: term()).
+is_sofs_set(S) when ?IS_SET(S) ->
+ true;
+is_sofs_set(S) when ?IS_ORDSET(S) ->
+ true;
+is_sofs_set(_S) ->
+ false.
+
+-spec(is_set(AnySet) -> Bool when
+ AnySet :: anyset(),
+ Bool :: boolean()).
+is_set(S) when ?IS_SET(S) ->
+ true;
+is_set(S) when ?IS_ORDSET(S) ->
+ false.
+
+-spec(is_empty_set(AnySet) -> Bool when
+ AnySet :: anyset(),
+ Bool :: boolean()).
+is_empty_set(S) when ?IS_SET(S) ->
+ ?LIST(S) =:= [];
+is_empty_set(S) when ?IS_ORDSET(S) ->
+ false.
+
+-spec(is_disjoint(Set1, Set2) -> Bool when
+ Bool :: boolean(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+is_disjoint(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ case match_types(?TYPE(S1), ?TYPE(S2)) of
+ true ->
+ case ?LIST(S1) of
+ [] -> true;
+ [A | As] -> disjoint(?LIST(S2), A, As)
+ end;
+ false -> erlang:error(type_mismatch)
+ end.
+
+%%%
+%%% Functions on set-of-sets.
+%%%
+
+-spec(union(SetOfSets) -> Set when
+ Set :: a_set(),
+ SetOfSets :: set_of_sets()).
+union(Sets) when ?IS_SET(Sets) ->
+ case ?TYPE(Sets) of
+ ?SET_OF(Type) -> ?SET(lunion(?LIST(Sets)), Type);
+ ?ANYTYPE -> Sets;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(intersection(SetOfSets) -> Set when
+ Set :: a_set(),
+ SetOfSets :: set_of_sets()).
+intersection(Sets) when ?IS_SET(Sets) ->
+ case ?LIST(Sets) of
+ [] -> erlang:error(badarg);
+ [L | Ls] ->
+ case ?TYPE(Sets) of
+ ?SET_OF(Type) ->
+ ?SET(lintersection(Ls, L), Type);
+ _ -> erlang:error(badarg)
+ end
+ end.
+
+-spec(canonical_relation(SetOfSets) -> BinRel when
+ BinRel :: binary_relation(),
+ SetOfSets :: set_of_sets()).
+canonical_relation(Sets) when ?IS_SET(Sets) ->
+ ST = ?TYPE(Sets),
+ case ST of
+ ?SET_OF(?ANYTYPE) -> empty_set();
+ ?SET_OF(Type) ->
+ ?SET(can_rel(?LIST(Sets), []), ?BINREL(Type, ST));
+ ?ANYTYPE -> Sets;
+ _ -> erlang:error(badarg)
+ end.
+
+%%%
+%%% Functions on binary relations only.
+%%%
+
+-spec(rel2fam(BinRel) -> Family when
+ Family :: family(),
+ BinRel :: binary_relation()).
+rel2fam(R) ->
+ relation_to_family(R).
+
+-spec(relation_to_family(BinRel) -> Family when
+ Family :: family(),
+ BinRel :: binary_relation()).
+%% Inlined.
+relation_to_family(R) when ?IS_SET(R) ->
+ case ?TYPE(R) of
+ ?BINREL(DT, RT) ->
+ ?SET(rel2family(?LIST(R)), ?FAMILY(DT, RT));
+ ?ANYTYPE -> R;
+ _Else -> erlang:error(badarg)
+ end.
+
+-spec(domain(BinRel) -> Set when
+ BinRel :: binary_relation(),
+ Set :: a_set()).
+domain(R) when ?IS_SET(R) ->
+ case ?TYPE(R) of
+ ?BINREL(DT, _) -> ?SET(dom(?LIST(R)), DT);
+ ?ANYTYPE -> R;
+ _Else -> erlang:error(badarg)
+ end.
+
+-spec(range(BinRel) -> Set when
+ BinRel :: binary_relation(),
+ Set :: a_set()).
+range(R) when ?IS_SET(R) ->
+ case ?TYPE(R) of
+ ?BINREL(_, RT) -> ?SET(ran(?LIST(R), []), RT);
+ ?ANYTYPE -> R;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(field(BinRel) -> Set when
+ BinRel :: binary_relation(),
+ Set :: a_set()).
+%% In "Introduction to LOGIC", Suppes defines the field of a binary
+%% relation to be the union of the domain and the range (or
+%% counterdomain).
+field(R) ->
+ union(domain(R), range(R)).
+
+-spec(relative_product(ListOfBinRels) -> BinRel2 when
+ ListOfBinRels :: [BinRel, ...],
+ BinRel :: binary_relation(),
+ BinRel2 :: binary_relation()).
+%% The following clause is kept for backward compatibility.
+%% The list is due to Dialyzer's specs.
+relative_product(RT) when is_tuple(RT) ->
+ relative_product(tuple_to_list(RT));
+relative_product(RL) when is_list(RL) ->
+ case relprod_n(RL, foo, false, false) of
+ {error, Reason} ->
+ erlang:error(Reason);
+ Reply ->
+ Reply
+ end.
+
+-spec(relative_product(ListOfBinRels, BinRel1) -> BinRel2 when
+ ListOfBinRels :: [BinRel, ...],
+ BinRel :: binary_relation(),
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation();
+ (BinRel1, BinRel2) -> BinRel3 when
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation(),
+ BinRel3 :: binary_relation()).
+relative_product(R1, R2) when ?IS_SET(R1), ?IS_SET(R2) ->
+ relative_product1(converse(R1), R2);
+%% The following clause is kept for backward compatibility.
+%% The list is due to Dialyzer's specs.
+relative_product(RT, R) when is_tuple(RT), ?IS_SET(R) ->
+ relative_product(tuple_to_list(RT), R);
+relative_product(RL, R) when is_list(RL), ?IS_SET(R) ->
+ EmptyR = case ?TYPE(R) of
+ ?BINREL(_, _) -> ?LIST(R) =:= [];
+ ?ANYTYPE -> true;
+ _ -> erlang:error(badarg)
+ end,
+ case relprod_n(RL, R, EmptyR, true) of
+ {error, Reason} ->
+ erlang:error(Reason);
+ Reply ->
+ Reply
+ end.
+
+-spec(relative_product1(BinRel1, BinRel2) -> BinRel3 when
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation(),
+ BinRel3 :: binary_relation()).
+relative_product1(R1, R2) when ?IS_SET(R1), ?IS_SET(R2) ->
+ {DTR1, RTR1} = case ?TYPE(R1) of
+ ?BINREL(_, _) = R1T -> R1T;
+ ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE};
+ _ -> erlang:error(badarg)
+ end,
+ {DTR2, RTR2} = case ?TYPE(R2) of
+ ?BINREL(_, _) = R2T -> R2T;
+ ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE};
+ _ -> erlang:error(badarg)
+ end,
+ case match_types(DTR1, DTR2) of
+ true when DTR1 =:= ?ANYTYPE -> R1;
+ true when DTR2 =:= ?ANYTYPE -> R2;
+ true -> ?SET(relprod(?LIST(R1), ?LIST(R2)), ?BINREL(RTR1, RTR2));
+ false -> erlang:error(type_mismatch)
+ end.
+
+-spec(converse(BinRel1) -> BinRel2 when
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation()).
+converse(R) when ?IS_SET(R) ->
+ case ?TYPE(R) of
+ ?BINREL(DT, RT) -> ?SET(converse(?LIST(R), []), ?BINREL(RT, DT));
+ ?ANYTYPE -> R;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(image(BinRel, Set1) -> Set2 when
+ BinRel :: binary_relation(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+image(R, S) when ?IS_SET(R), ?IS_SET(S) ->
+ case ?TYPE(R) of
+ ?BINREL(DT, RT) ->
+ case match_types(DT, ?TYPE(S)) of
+ true ->
+ ?SET(usort(restrict(?LIST(S), ?LIST(R))), RT);
+ false ->
+ erlang:error(type_mismatch)
+ end;
+ ?ANYTYPE -> R;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(inverse_image(BinRel, Set1) -> Set2 when
+ BinRel :: binary_relation(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+inverse_image(R, S) when ?IS_SET(R), ?IS_SET(S) ->
+ case ?TYPE(R) of
+ ?BINREL(DT, RT) ->
+ case match_types(RT, ?TYPE(S)) of
+ true ->
+ NL = restrict(?LIST(S), converse(?LIST(R), [])),
+ ?SET(usort(NL), DT);
+ false ->
+ erlang:error(type_mismatch)
+ end;
+ ?ANYTYPE -> R;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(strict_relation(BinRel1) -> BinRel2 when
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation()).
+strict_relation(R) when ?IS_SET(R) ->
+ case ?TYPE(R) of
+ Type = ?BINREL(_, _) ->
+ ?SET(strict(?LIST(R), []), Type);
+ ?ANYTYPE -> R;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(weak_relation(BinRel1) -> BinRel2 when
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation()).
+weak_relation(R) when ?IS_SET(R) ->
+ case ?TYPE(R) of
+ ?BINREL(DT, RT) ->
+ case unify_types(DT, RT) of
+ [] ->
+ erlang:error(badarg);
+ Type ->
+ ?SET(weak(?LIST(R)), ?BINREL(Type, Type))
+ end;
+ ?ANYTYPE -> R;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(extension(BinRel1, Set, AnySet) -> BinRel2 when
+ AnySet :: anyset(),
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation(),
+ Set :: a_set()).
+extension(R, S, E) when ?IS_SET(R), ?IS_SET(S) ->
+ case {?TYPE(R), ?TYPE(S), is_sofs_set(E)} of
+ {T=?BINREL(DT, RT), ST, true} ->
+ case match_types(DT, ST) and match_types(RT, type(E)) of
+ false ->
+ erlang:error(type_mismatch);
+ true ->
+ RL = ?LIST(R),
+ case extc([], ?LIST(S), to_external(E), RL) of
+ [] ->
+ R;
+ L ->
+ ?SET(merge(RL, reverse(L)), T)
+ end
+ end;
+ {?ANYTYPE, ?ANYTYPE, true} ->
+ R;
+ {?ANYTYPE, ST, true} ->
+ case type(E) of
+ ?SET_OF(?ANYTYPE) ->
+ R;
+ ET ->
+ ?SET([], ?BINREL(ST, ET))
+ end;
+ {_, _, true} ->
+ erlang:error(badarg)
+ end.
+
+-spec(is_a_function(BinRel) -> Bool when
+ Bool :: boolean(),
+ BinRel :: binary_relation()).
+is_a_function(R) when ?IS_SET(R) ->
+ case ?TYPE(R) of
+ ?BINREL(_, _) ->
+ case ?LIST(R) of
+ [] -> true;
+ [{V,_} | Es] -> is_a_func(Es, V)
+ end;
+ ?ANYTYPE -> true;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(restriction(BinRel1, Set) -> BinRel2 when
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation(),
+ Set :: a_set()).
+restriction(Relation, Set) ->
+ restriction(1, Relation, Set).
+
+-spec(drestriction(BinRel1, Set) -> BinRel2 when
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation(),
+ Set :: a_set()).
+drestriction(Relation, Set) ->
+ drestriction(1, Relation, Set).
+
+%%%
+%%% Functions on functions only.
+%%%
+
+-spec(composite(Function1, Function2) -> Function3 when
+ Function1 :: a_function(),
+ Function2 :: a_function(),
+ Function3 :: a_function()).
+composite(Fn1, Fn2) when ?IS_SET(Fn1), ?IS_SET(Fn2) ->
+ ?BINREL(DTF1, RTF1) = case ?TYPE(Fn1)of
+ ?BINREL(_, _) = F1T -> F1T;
+ ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE};
+ _ -> erlang:error(badarg)
+ end,
+ ?BINREL(DTF2, RTF2) = case ?TYPE(Fn2) of
+ ?BINREL(_, _) = F2T -> F2T;
+ ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE};
+ _ -> erlang:error(badarg)
+ end,
+ case match_types(RTF1, DTF2) of
+ true when DTF1 =:= ?ANYTYPE -> Fn1;
+ true when DTF2 =:= ?ANYTYPE -> Fn2;
+ true ->
+ case comp(?LIST(Fn1), ?LIST(Fn2)) of
+ SL when is_list(SL) ->
+ ?SET(sort(SL), ?BINREL(DTF1, RTF2));
+ Bad ->
+ erlang:error(Bad)
+ end;
+ false -> erlang:error(type_mismatch)
+ end.
+
+-spec(inverse(Function1) -> Function2 when
+ Function1 :: a_function(),
+ Function2 :: a_function()).
+inverse(Fn) when ?IS_SET(Fn) ->
+ case ?TYPE(Fn) of
+ ?BINREL(DT, RT) ->
+ case inverse1(?LIST(Fn)) of
+ SL when is_list(SL) ->
+ ?SET(SL, ?BINREL(RT, DT));
+ Bad ->
+ erlang:error(Bad)
+ end;
+ ?ANYTYPE -> Fn;
+ _ -> erlang:error(badarg)
+ end.
+
+%%%
+%%% Functions on relations (binary or other).
+%%%
+
+-spec(restriction(SetFun, Set1, Set2) -> Set3 when
+ SetFun :: set_fun(),
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set()).
+%% Equivalent to range(restriction(inverse(substitution(Fun, S1)), S2)).
+restriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) ->
+ RT = ?TYPE(R),
+ ST = ?TYPE(S),
+ case check_for_sort(RT, I) of
+ empty ->
+ R;
+ error ->
+ erlang:error(badarg);
+ Sort ->
+ RL = ?LIST(R),
+ case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of
+ {true, _SL} when RL =:= [] ->
+ R;
+ {true, []} ->
+ ?SET([], RT);
+ {true, [E | Es]} when Sort =:= false -> % I =:= 1
+ ?SET(reverse(restrict_n(I, RL, E, Es, [])), RT);
+ {true, [E | Es]} ->
+ ?SET(sort(restrict_n(I, keysort(I, RL), E, Es, [])), RT);
+ {false, _SL} ->
+ erlang:error(type_mismatch)
+ end
+ end;
+restriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ Type1 = ?TYPE(S1),
+ Type2 = ?TYPE(S2),
+ SL1 = ?LIST(S1),
+ case external_fun(SetFun) of
+ false when Type2 =:= ?ANYTYPE ->
+ S2;
+ false ->
+ case subst(SL1, SetFun, element_type(Type1)) of
+ {NSL, NewType} -> % NewType can be ?ANYTYPE
+ case match_types(NewType, Type2) of
+ true ->
+ NL = sort(restrict(?LIST(S2), converse(NSL, []))),
+ ?SET(NL, Type1);
+ false ->
+ erlang:error(type_mismatch)
+ end;
+ Bad ->
+ erlang:error(Bad)
+ end;
+ _ when Type1 =:= ?ANYTYPE ->
+ S1;
+ _XFun when ?IS_SET_OF(Type1) ->
+ erlang:error(badarg);
+ XFun ->
+ FunT = XFun(Type1),
+ try check_fun(Type1, XFun, FunT) of
+ Sort ->
+ case match_types(FunT, Type2) of
+ true ->
+ R1 = inverse_substitution(SL1, XFun, Sort),
+ ?SET(sort(Sort, restrict(?LIST(S2), R1)), Type1);
+ false ->
+ erlang:error(type_mismatch)
+ end
+ catch _:_ -> erlang:error(badarg)
+ end
+ end.
+
+-spec(drestriction(SetFun, Set1, Set2) -> Set3 when
+ SetFun :: set_fun(),
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set()).
+drestriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) ->
+ RT = ?TYPE(R),
+ ST = ?TYPE(S),
+ case check_for_sort(RT, I) of
+ empty ->
+ R;
+ error ->
+ erlang:error(badarg);
+ Sort ->
+ RL = ?LIST(R),
+ case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of
+ {true, []} ->
+ R;
+ {true, _SL} when RL =:= [] ->
+ R;
+ {true, [E | Es]} when Sort =:= false -> % I =:= 1
+ ?SET(diff_restrict_n(I, RL, E, Es, []), RT);
+ {true, [E | Es]} ->
+ ?SET(diff_restrict_n(I, keysort(I, RL), E, Es, []), RT);
+ {false, _SL} ->
+ erlang:error(type_mismatch)
+ end
+ end;
+drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ Type1 = ?TYPE(S1),
+ Type2 = ?TYPE(S2),
+ SL1 = ?LIST(S1),
+ case external_fun(SetFun) of
+ false when Type2 =:= ?ANYTYPE ->
+ S1;
+ false ->
+ case subst(SL1, SetFun, element_type(Type1)) of
+ {NSL, NewType} -> % NewType can be ?ANYTYPE
+ case match_types(NewType, Type2) of
+ true ->
+ SL2 = ?LIST(S2),
+ NL = sort(diff_restrict(SL2, converse(NSL, []))),
+ ?SET(NL, Type1);
+ false ->
+ erlang:error(type_mismatch)
+ end;
+ Bad ->
+ erlang:error(Bad)
+ end;
+ _ when Type1 =:= ?ANYTYPE ->
+ S1;
+ _XFun when ?IS_SET_OF(Type1) ->
+ erlang:error(badarg);
+ XFun ->
+ FunT = XFun(Type1),
+ try check_fun(Type1, XFun, FunT) of
+ Sort ->
+ case match_types(FunT, Type2) of
+ true ->
+ R1 = inverse_substitution(SL1, XFun, Sort),
+ SL2 = ?LIST(S2),
+ ?SET(sort(Sort, diff_restrict(SL2, R1)), Type1);
+ false ->
+ erlang:error(type_mismatch)
+ end
+ catch _:_ -> erlang:error(badarg)
+ end
+ end.
+
+-spec(projection(SetFun, Set1) -> Set2 when
+ SetFun :: set_fun(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+projection(I, Set) when is_integer(I), ?IS_SET(Set) ->
+ Type = ?TYPE(Set),
+ case check_for_sort(Type, I) of
+ empty ->
+ Set;
+ error ->
+ erlang:error(badarg);
+ _ when I =:= 1 ->
+ ?SET(projection1(?LIST(Set)), ?REL_TYPE(I, Type));
+ _ ->
+ ?SET(projection_n(?LIST(Set), I, []), ?REL_TYPE(I, Type))
+ end;
+projection(Fun, Set) ->
+ range(substitution(Fun, Set)).
+
+-spec(substitution(SetFun, Set1) -> Set2 when
+ SetFun :: set_fun(),
+ Set1 :: a_set(),
+ Set2 :: a_set()).
+substitution(I, Set) when is_integer(I), ?IS_SET(Set) ->
+ Type = ?TYPE(Set),
+ case check_for_sort(Type, I) of
+ empty ->
+ Set;
+ error ->
+ erlang:error(badarg);
+ _Sort ->
+ NType = ?REL_TYPE(I, Type),
+ NSL = substitute_element(?LIST(Set), I, []),
+ ?SET(NSL, ?BINREL(Type, NType))
+ end;
+substitution(SetFun, Set) when ?IS_SET(Set) ->
+ Type = ?TYPE(Set),
+ L = ?LIST(Set),
+ case external_fun(SetFun) of
+ false when L =/= [] ->
+ case subst(L, SetFun, element_type(Type)) of
+ {SL, NewType} ->
+ ?SET(reverse(SL), ?BINREL(Type, NewType));
+ Bad ->
+ erlang:error(Bad)
+ end;
+ false ->
+ empty_set();
+ _ when Type =:= ?ANYTYPE ->
+ empty_set();
+ _XFun when ?IS_SET_OF(Type) ->
+ erlang:error(badarg);
+ XFun ->
+ FunT = XFun(Type),
+ try check_fun(Type, XFun, FunT) of
+ _Sort ->
+ SL = substitute(L, XFun, []),
+ ?SET(SL, ?BINREL(Type, FunT))
+ catch _:_ -> erlang:error(badarg)
+ end
+ end.
+
+-spec(partition(SetOfSets) -> Partition when
+ SetOfSets :: set_of_sets(),
+ Partition :: a_set()).
+partition(Sets) ->
+ F1 = relation_to_family(canonical_relation(Sets)),
+ F2 = relation_to_family(converse(F1)),
+ range(F2).
+
+-spec(partition(SetFun, Set) -> Partition when
+ SetFun :: set_fun(),
+ Partition :: a_set(),
+ Set :: a_set()).
+partition(I, Set) when is_integer(I), ?IS_SET(Set) ->
+ Type = ?TYPE(Set),
+ case check_for_sort(Type, I) of
+ empty ->
+ Set;
+ error ->
+ erlang:error(badarg);
+ false -> % I =:= 1
+ ?SET(partition_n(I, ?LIST(Set)), ?SET_OF(Type));
+ true ->
+ ?SET(partition_n(I, keysort(I, ?LIST(Set))), ?SET_OF(Type))
+ end;
+partition(Fun, Set) ->
+ range(partition_family(Fun, Set)).
+
+-spec(partition(SetFun, Set1, Set2) -> {Set3, Set4} when
+ SetFun :: set_fun(),
+ Set1 :: a_set(),
+ Set2 :: a_set(),
+ Set3 :: a_set(),
+ Set4 :: a_set()).
+partition(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) ->
+ RT = ?TYPE(R),
+ ST = ?TYPE(S),
+ case check_for_sort(RT, I) of
+ empty ->
+ {R, R};
+ error ->
+ erlang:error(badarg);
+ Sort ->
+ RL = ?LIST(R),
+ case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of
+ {true, _SL} when RL =:= [] ->
+ {R, R};
+ {true, []} ->
+ {?SET([], RT), R};
+ {true, [E | Es]} when Sort =:= false -> % I =:= 1
+ [L1 | L2] = partition3_n(I, RL, E, Es, [], []),
+ {?SET(L1, RT), ?SET(L2, RT)};
+ {true, [E | Es]} ->
+ [L1 | L2] = partition3_n(I, keysort(I,RL), E, Es, [], []),
+ {?SET(L1, RT), ?SET(L2, RT)};
+ {false, _SL} ->
+ erlang:error(type_mismatch)
+ end
+ end;
+partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
+ Type1 = ?TYPE(S1),
+ Type2 = ?TYPE(S2),
+ SL1 = ?LIST(S1),
+ case external_fun(SetFun) of
+ false when Type2 =:= ?ANYTYPE ->
+ {S2, S1};
+ false ->
+ case subst(SL1, SetFun, element_type(Type1)) of
+ {NSL, NewType} -> % NewType can be ?ANYTYPE
+ case match_types(NewType, Type2) of
+ true ->
+ R1 = converse(NSL, []),
+ [L1 | L2] = partition3(?LIST(S2), R1),
+ {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)};
+ false ->
+ erlang:error(type_mismatch)
+ end;
+ Bad ->
+ erlang:error(Bad)
+ end;
+ _ when Type1 =:= ?ANYTYPE ->
+ {S1, S1};
+ _XFun when ?IS_SET_OF(Type1) ->
+ erlang:error(badarg);
+ XFun ->
+ FunT = XFun(Type1),
+ try check_fun(Type1, XFun, FunT) of
+ Sort ->
+ case match_types(FunT, Type2) of
+ true ->
+ R1 = inverse_substitution(SL1, XFun, Sort),
+ [L1 | L2] = partition3(?LIST(S2), R1),
+ {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)};
+ false ->
+ erlang:error(type_mismatch)
+ end
+ catch _:_ -> erlang:error(badarg)
+ end
+ end.
+
+-spec(multiple_relative_product(TupleOfBinRels, BinRel1) -> BinRel2 when
+ TupleOfBinRels :: tuple_of(BinRel),
+ BinRel :: binary_relation(),
+ BinRel1 :: binary_relation(),
+ BinRel2 :: binary_relation()).
+multiple_relative_product(T, R) when is_tuple(T), ?IS_SET(R) ->
+ case test_rel(R, tuple_size(T), eq) of
+ true when ?TYPE(R) =:= ?ANYTYPE ->
+ empty_set();
+ true ->
+ MProd = mul_relprod(tuple_to_list(T), 1, R),
+ relative_product(MProd);
+ false ->
+ erlang:error(badarg)
+ end.
+
+-spec(join(Relation1, I, Relation2, J) -> Relation3 when
+ Relation1 :: relation(),
+ Relation2 :: relation(),
+ Relation3 :: relation(),
+ I :: pos_integer(),
+ J :: pos_integer()).
+join(R1, I1, R2, I2)
+ when ?IS_SET(R1), ?IS_SET(R2), is_integer(I1), is_integer(I2) ->
+ case test_rel(R1, I1, lte) and test_rel(R2, I2, lte) of
+ false -> erlang:error(badarg);
+ true when ?TYPE(R1) =:= ?ANYTYPE -> R1;
+ true when ?TYPE(R2) =:= ?ANYTYPE -> R2;
+ true ->
+ L1 = ?LIST(raise_element(R1, I1)),
+ L2 = ?LIST(raise_element(R2, I2)),
+ T = relprod1(L1, L2),
+ F = case (I1 =:= 1) and (I2 =:= 1) of
+ true ->
+ fun({X,Y}) -> join_element(X, Y) end;
+ false ->
+ fun({X,Y}) ->
+ list_to_tuple(join_element(X, Y, I2))
+ end
+ end,
+ ?SET(replace(T, F, []), F({?TYPE(R1), ?TYPE(R2)}))
+ end.
+
+%% Inlined.
+test_rel(R, I, C) ->
+ case ?TYPE(R) of
+ Rel when ?IS_RELATION(Rel), C =:= eq, I =:= ?REL_ARITY(Rel) -> true;
+ Rel when ?IS_RELATION(Rel), C =:= lte, I>=1, I =< ?REL_ARITY(Rel) ->
+ true;
+ ?ANYTYPE -> true;
+ _ -> false
+ end.
+
+%%%
+%%% Family functions
+%%%
+
+-spec(fam2rel(Family) -> BinRel when
+ Family :: family(),
+ BinRel :: binary_relation()).
+fam2rel(F) ->
+ family_to_relation(F).
+
+-spec(family_to_relation(Family) -> BinRel when
+ Family :: family(),
+ BinRel :: binary_relation()).
+%% Inlined.
+family_to_relation(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(DT, RT) ->
+ ?SET(family2rel(?LIST(F), []), ?BINREL(DT, RT));
+ ?ANYTYPE -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(family_specification(Fun, Family1) -> Family2 when
+ Fun :: spec_fun(),
+ Family1 :: family(),
+ Family2 :: family()).
+family_specification(Fun, F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(_DT, Type) = FType ->
+ R = case external_fun(Fun) of
+ false ->
+ fam_spec(?LIST(F), Fun, Type, []);
+ XFun ->
+ fam_specification(?LIST(F), XFun, [])
+ end,
+ case R of
+ SL when is_list(SL) ->
+ ?SET(SL, FType);
+ Bad ->
+ erlang:error(Bad)
+ end;
+ ?ANYTYPE -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(union_of_family(Family) -> Set when
+ Family :: family(),
+ Set :: a_set()).
+union_of_family(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(_DT, Type) ->
+ ?SET(un_of_fam(?LIST(F), []), Type);
+ ?ANYTYPE -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(intersection_of_family(Family) -> Set when
+ Family :: family(),
+ Set :: a_set()).
+intersection_of_family(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(_DT, Type) ->
+ case int_of_fam(?LIST(F)) of
+ FU when is_list(FU) ->
+ ?SET(FU, Type);
+ Bad ->
+ erlang:error(Bad)
+ end;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(family_union(Family1) -> Family2 when
+ Family1 :: family(),
+ Family2 :: family()).
+family_union(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(DT, ?SET_OF(Type)) ->
+ ?SET(fam_un(?LIST(F), []), ?FAMILY(DT, Type));
+ ?ANYTYPE -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(family_intersection(Family1) -> Family2 when
+ Family1 :: family(),
+ Family2 :: family()).
+family_intersection(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(DT, ?SET_OF(Type)) ->
+ case fam_int(?LIST(F), []) of
+ FU when is_list(FU) ->
+ ?SET(FU, ?FAMILY(DT, Type));
+ Bad ->
+ erlang:error(Bad)
+ end;
+ ?ANYTYPE -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(family_domain(Family1) -> Family2 when
+ Family1 :: family(),
+ Family2 :: family()).
+family_domain(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(FDT, ?BINREL(DT, _)) ->
+ ?SET(fam_dom(?LIST(F), []), ?FAMILY(FDT, DT));
+ ?ANYTYPE -> F;
+ ?FAMILY(_, ?ANYTYPE) -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(family_range(Family1) -> Family2 when
+ Family1 :: family(),
+ Family2 :: family()).
+family_range(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(DT, ?BINREL(_, RT)) ->
+ ?SET(fam_ran(?LIST(F), []), ?FAMILY(DT, RT));
+ ?ANYTYPE -> F;
+ ?FAMILY(_, ?ANYTYPE) -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(family_field(Family1) -> Family2 when
+ Family1 :: family(),
+ Family2 :: family()).
+family_field(F) ->
+ family_union(family_domain(F), family_range(F)).
+
+-spec(family_union(Family1, Family2) -> Family3 when
+ Family1 :: family(),
+ Family2 :: family(),
+ Family3 :: family()).
+family_union(F1, F2) ->
+ fam_binop(F1, F2, fun fam_union/3).
+
+-spec(family_intersection(Family1, Family2) -> Family3 when
+ Family1 :: family(),
+ Family2 :: family(),
+ Family3 :: family()).
+family_intersection(F1, F2) ->
+ fam_binop(F1, F2, fun fam_intersect/3).
+
+-spec(family_difference(Family1, Family2) -> Family3 when
+ Family1 :: family(),
+ Family2 :: family(),
+ Family3 :: family()).
+family_difference(F1, F2) ->
+ fam_binop(F1, F2, fun fam_difference/3).
+
+%% Inlined.
+fam_binop(F1, F2, FF) when ?IS_SET(F1), ?IS_SET(F2) ->
+ case unify_types(?TYPE(F1), ?TYPE(F2)) of
+ [] ->
+ erlang:error(type_mismatch);
+ ?ANYTYPE ->
+ F1;
+ Type = ?FAMILY(_, _) ->
+ ?SET(FF(?LIST(F1), ?LIST(F2), []), Type);
+ _ -> erlang:error(badarg)
+ end.
+
+-spec(partition_family(SetFun, Set) -> Family when
+ Family :: family(),
+ SetFun :: set_fun(),
+ Set :: a_set()).
+partition_family(I, Set) when is_integer(I), ?IS_SET(Set) ->
+ Type = ?TYPE(Set),
+ case check_for_sort(Type, I) of
+ empty ->
+ Set;
+ error ->
+ erlang:error(badarg);
+ false -> % when I =:= 1
+ ?SET(fam_partition_n(I, ?LIST(Set)),
+ ?BINREL(?REL_TYPE(I, Type), ?SET_OF(Type)));
+ true ->
+ ?SET(fam_partition_n(I, keysort(I, ?LIST(Set))),
+ ?BINREL(?REL_TYPE(I, Type), ?SET_OF(Type)))
+ end;
+partition_family(SetFun, Set) when ?IS_SET(Set) ->
+ Type = ?TYPE(Set),
+ SL = ?LIST(Set),
+ case external_fun(SetFun) of
+ false when SL =/= [] ->
+ case subst(SL, SetFun, element_type(Type)) of
+ {NSL, NewType} ->
+ P = fam_partition(converse(NSL, []), true),
+ ?SET(reverse(P), ?BINREL(NewType, ?SET_OF(Type)));
+ Bad ->
+ erlang:error(Bad)
+ end;
+ false ->
+ empty_set();
+ _ when Type =:= ?ANYTYPE ->
+ empty_set();
+ _XFun when ?IS_SET_OF(Type) ->
+ erlang:error(badarg);
+ XFun ->
+ DType = XFun(Type),
+ try check_fun(Type, XFun, DType) of
+ Sort ->
+ Ts = inverse_substitution(?LIST(Set), XFun, Sort),
+ P = fam_partition(Ts, Sort),
+ ?SET(reverse(P), ?BINREL(DType, ?SET_OF(Type)))
+ catch _:_ -> erlang:error(badarg)
+ end
+ end.
+
+-spec(family_projection(SetFun, Family1) -> Family2 when
+ SetFun :: set_fun(),
+ Family1 :: family(),
+ Family2 :: family()).
+family_projection(SetFun, F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(_, _) when [] =:= ?LIST(F) ->
+ empty_set();
+ ?FAMILY(DT, Type) ->
+ case external_fun(SetFun) of
+ false ->
+ case fam_proj(?LIST(F), SetFun, Type, ?ANYTYPE, []) of
+ {SL, NewType} ->
+ ?SET(SL, ?BINREL(DT, NewType));
+ Bad ->
+ erlang:error(Bad)
+ end;
+ _ ->
+ erlang:error(badarg)
+ end;
+ ?ANYTYPE -> F;
+ _ -> erlang:error(badarg)
+ end.
+
+%%%
+%%% Digraph functions
+%%%
+
+-spec(family_to_digraph(Family) -> Graph when
+ Graph :: digraph:graph(),
+ Family :: family()).
+family_to_digraph(F) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(_, _) -> fam2digraph(F, digraph:new());
+ ?ANYTYPE -> digraph:new();
+ _Else -> erlang:error(badarg)
+ end.
+
+-spec(family_to_digraph(Family, GraphType) -> Graph when
+ Graph :: digraph:graph(),
+ Family :: family(),
+ GraphType :: [digraph:d_type()]).
+family_to_digraph(F, Type) when ?IS_SET(F) ->
+ case ?TYPE(F) of
+ ?FAMILY(_, _) -> ok;
+ ?ANYTYPE -> ok;
+ _Else -> erlang:error(badarg)
+ end,
+ try digraph:new(Type) of
+ G -> case catch fam2digraph(F, G) of
+ {error, Reason} ->
+ true = digraph:delete(G),
+ erlang:error(Reason);
+ _ ->
+ G
+ end
+ catch
+ error:badarg -> erlang:error(badarg)
+ end.
+
+-spec(digraph_to_family(Graph) -> Family when
+ Graph :: digraph:graph(),
+ Family :: family()).
+digraph_to_family(G) ->
+ try digraph_family(G) of
+ L -> ?SET(L, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE))
+ catch _:_ -> erlang:error(badarg)
+ end.
+
+-spec(digraph_to_family(Graph, Type) -> Family when
+ Graph :: digraph:graph(),
+ Family :: family(),
+ Type :: type()).
+digraph_to_family(G, T) ->
+ case {is_type(T), T} of
+ {true, ?SET_OF(?FAMILY(_,_) = Type)} ->
+ try digraph_family(G) of
+ L -> ?SET(L, Type)
+ catch _:_ -> erlang:error(badarg)
+ end;
+ _ ->
+ erlang:error(badarg)
+ end.
+
+%%
+%% Local functions
+%%
+
+%% Type = OrderedSetType
+%% | SetType
+%% | atom() except '_'
+%% OrderedSetType = {Type, ..., Type}
+%% SetType = [ElementType] % list of exactly one element
+%% ElementType = '_' % any type (implies empty set)
+%% | Type
+
+is_types(0, _T) ->
+ true;
+is_types(I, T) ->
+ case is_type(?REL_TYPE(I, T)) of
+ true -> is_types(I-1, T);
+ false -> false
+ end.
+
+is_element_type(?ANYTYPE) ->
+ true;
+is_element_type(T) ->
+ is_type(T).
+
+set_of_sets([S | Ss], L, T0) when ?IS_SET(S) ->
+ case unify_types([?TYPE(S)], T0) of
+ [] -> {error, type_mismatch};
+ Type -> set_of_sets(Ss, [?LIST(S) | L], Type)
+ end;
+set_of_sets([S | Ss], L, T0) when ?IS_ORDSET(S) ->
+ case unify_types(?ORDTYPE(S), T0) of
+ [] -> {error, type_mismatch};
+ Type -> set_of_sets(Ss, [?ORDDATA(S) | L], Type)
+ end;
+set_of_sets([], L, T) ->
+ ?SET(usort(L), T);
+set_of_sets(_, _L, _T) ->
+ {error, badarg}.
+
+ordset_of_sets([S | Ss], L, T) when ?IS_SET(S) ->
+ ordset_of_sets(Ss, [?LIST(S) | L], [[?TYPE(S)] | T]);
+ordset_of_sets([S | Ss], L, T) when ?IS_ORDSET(S) ->
+ ordset_of_sets(Ss, [?ORDDATA(S) | L], [?ORDTYPE(S) | T]);
+ordset_of_sets([], L, T) ->
+ ?ORDSET(list_to_tuple(reverse(L)), list_to_tuple(reverse(T)));
+ordset_of_sets(_, _L, _T) ->
+ error.
+
+%% Inlined.
+rel(Ts, [Type]) ->
+ case is_type(Type) and atoms_only(Type, 1) of
+ true ->
+ rel(Ts, tuple_size(Type), Type);
+ false ->
+ rel_type(Ts, [], Type)
+ end;
+rel(Ts, Sz) ->
+ rel(Ts, Sz, erlang:make_tuple(Sz, ?ATOM_TYPE)).
+
+atoms_only(Type, I) when ?IS_ATOM_TYPE(?REL_TYPE(I, Type)) ->
+ atoms_only(Type, I+1);
+atoms_only(Type, I) when I > tuple_size(Type), ?IS_RELATION(Type) ->
+ true;
+atoms_only(_Type, _I) ->
+ false.
+
+rel(Ts, Sz, Type) when Sz >= 1 ->
+ SL = usort(Ts),
+ rel(SL, SL, Sz, Type).
+
+rel([T | Ts], L, Sz, Type) when tuple_size(T) =:= Sz ->
+ rel(Ts, L, Sz, Type);
+rel([], L, _Sz, Type) ->
+ ?SET(L, Type).
+
+rel_type([E | Ts], L, Type) ->
+ {NType, NE} = make_element(E, Type, Type),
+ rel_type(Ts, [NE | L], NType);
+rel_type([], [], ?ANYTYPE) ->
+ empty_set();
+rel_type([], SL, Type) when ?IS_RELATION(Type) ->
+ ?SET(usort(SL), Type).
+
+%% Inlined.
+a_func(Ts, T) ->
+ case {T, is_type(T)} of
+ {[?BINREL(DT, RT) = Type], true} when ?IS_ATOM_TYPE(DT),
+ ?IS_ATOM_TYPE(RT) ->
+ func(Ts, Type);
+ {[Type], true} ->
+ func_type(Ts, [], Type, fun(?BINREL(_,_)) -> true end)
+ end.
+
+func(L0, Type) ->
+ L = usort(L0),
+ func(L, L, L, Type).
+
+func([{X,_} | Ts], X0, L, Type) when X /= X0 ->
+ func(Ts, X, L, Type);
+func([{X,_} | _Ts], X0, _L, _Type) when X == X0 ->
+ bad_function;
+func([], _X0, L, Type) ->
+ ?SET(L, Type).
+
+%% Inlined.
+fam(Ts, T) ->
+ case {T, is_type(T)} of
+ {[?FAMILY(DT, RT) = Type], true} when ?IS_ATOM_TYPE(DT),
+ ?IS_ATOM_TYPE(RT) ->
+ fam2(Ts, Type);
+ {[Type], true} ->
+ func_type(Ts, [], Type, fun(?FAMILY(_,_)) -> true end)
+ end.
+
+fam2([], Type) ->
+ ?SET([], Type);
+fam2(Ts, Type) ->
+ fam2(sort(Ts), Ts, [], Type).
+
+fam2([{I,L} | T], I0, SL, Type) when I /= I0 ->
+ fam2(T, I, [{I,usort(L)} | SL], Type);
+fam2([{I,L} | T], I0, SL, Type) when I == I0 ->
+ case {usort(L), SL} of
+ {NL, [{_I,NL1} | _]} when NL == NL1 ->
+ fam2(T, I0, SL, Type);
+ _ ->
+ bad_function
+ end;
+fam2([], _I0, SL, Type) ->
+ ?SET(reverse(SL), Type).
+
+func_type([E | T], SL, Type, F) ->
+ {NType, NE} = make_element(E, Type, Type),
+ func_type(T, [NE | SL], NType, F);
+func_type([], [], ?ANYTYPE, _F) ->
+ empty_set();
+func_type([], SL, Type, F) ->
+ true = F(Type),
+ NL = usort(SL),
+ check_function(NL, ?SET(NL, Type)).
+
+setify(L, ?SET_OF(Atom)) when ?IS_ATOM_TYPE(Atom), Atom =/= ?ANYTYPE ->
+ ?SET(usort(L), Atom);
+setify(L, ?SET_OF(Type0)) ->
+ try is_no_lists(Type0) of
+ N when is_integer(N) ->
+ rel(L, N, Type0);
+ Sizes ->
+ make_oset(L, Sizes, L, Type0)
+ catch
+ _:_ ->
+ {?SET_OF(Type), Set} = create(L, Type0, Type0, []),
+ ?SET(Set, Type)
+ end;
+setify(E, Type0) ->
+ {Type, OrdSet} = make_element(E, Type0, Type0),
+ ?ORDSET(OrdSet, Type).
+
+is_no_lists(T) when is_tuple(T) ->
+ Sz = tuple_size(T),
+ is_no_lists(T, Sz, Sz, []).
+
+is_no_lists(_T, 0, Sz, []) ->
+ Sz;
+is_no_lists(_T, 0, Sz, L) ->
+ {Sz, L};
+is_no_lists(T, I, Sz, L) when ?IS_ATOM_TYPE(?REL_TYPE(I, T)) ->
+ is_no_lists(T, I-1, Sz, L);
+is_no_lists(T, I, Sz, L) ->
+ is_no_lists(T, I-1, Sz, [{I,is_no_lists(?REL_TYPE(I, T))} | L]).
+
+create([E | Es], T, T0, L) ->
+ {NT, S} = make_element(E, T, T0),
+ create(Es, NT, T0, [S | L]);
+create([], T, _T0, L) ->
+ {?SET_OF(T), usort(L)}.
+
+make_element(C, ?ANYTYPE, _T0) ->
+ make_element(C);
+make_element(C, Atom, ?ANYTYPE) when ?IS_ATOM_TYPE(Atom),
+ not is_list(C), not is_tuple(C) ->
+ {Atom, C};
+make_element(C, Atom, Atom) when ?IS_ATOM_TYPE(Atom) ->
+ {Atom, C};
+make_element(T, TT, ?ANYTYPE) when tuple_size(T) =:= tuple_size(TT) ->
+ make_tuple(tuple_to_list(T), tuple_to_list(TT), [], [], ?ANYTYPE);
+make_element(T, TT, T0) when tuple_size(T) =:= tuple_size(TT) ->
+ make_tuple(tuple_to_list(T), tuple_to_list(TT), [], [], tuple_to_list(T0));
+make_element(L, [LT], ?ANYTYPE) when is_list(L) ->
+ create(L, LT, ?ANYTYPE, []);
+make_element(L, [LT], [T0]) when is_list(L) ->
+ create(L, LT, T0, []).
+
+make_tuple([E | Es], [T | Ts], NT, L, T0) when T0 =:= ?ANYTYPE ->
+ {ET, ES} = make_element(E, T, T0),
+ make_tuple(Es, Ts, [ET | NT], [ES | L], T0);
+make_tuple([E | Es], [T | Ts], NT, L, [T0 | T0s]) ->
+ {ET, ES} = make_element(E, T, T0),
+ make_tuple(Es, Ts, [ET | NT], [ES | L], T0s);
+make_tuple([], [], NT, L, _T0s) when NT =/= [] ->
+ {list_to_tuple(reverse(NT)), list_to_tuple(reverse(L))}.
+
+%% Derive type.
+make_element(C) when not is_list(C), not is_tuple(C) ->
+ {?ATOM_TYPE, C};
+make_element(T) when is_tuple(T) ->
+ make_tuple(tuple_to_list(T), [], []);
+make_element(L) when is_list(L) ->
+ create(L, ?ANYTYPE, ?ANYTYPE, []).
+
+make_tuple([E | Es], T, L) ->
+ {ET, ES} = make_element(E),
+ make_tuple(Es, [ET | T], [ES | L]);
+make_tuple([], T, L) when T =/= [] ->
+ {list_to_tuple(reverse(T)), list_to_tuple(reverse(L))}.
+
+make_oset([T | Ts], Szs, L, Type) ->
+ true = test_oset(Szs, T, T),
+ make_oset(Ts, Szs, L, Type);
+make_oset([], _Szs, L, Type) ->
+ ?SET(usort(L), Type).
+
+%% Optimization. Avoid re-building (nested) tuples.
+test_oset({Sz,Args}, T, T0) when tuple_size(T) =:= Sz ->
+ test_oset_args(Args, T, T0);
+test_oset(Sz, T, _T0) when tuple_size(T) =:= Sz ->
+ true.
+
+test_oset_args([{Arg,Szs} | Ss], T, T0) ->
+ true = test_oset(Szs, ?REL_TYPE(Arg, T), T0),
+ test_oset_args(Ss, T, T0);
+test_oset_args([], _T, _T0) ->
+ true.
+
+list_of_sets([S | Ss], Type, L) ->
+ list_of_sets(Ss, Type, [?SET(S, Type) | L]);
+list_of_sets([], _Type, L) ->
+ reverse(L).
+
+list_of_ordsets([S | Ss], Type, L) ->
+ list_of_ordsets(Ss, Type, [?ORDSET(S, Type) | L]);
+list_of_ordsets([], _Type, L) ->
+ reverse(L).
+
+tuple_of_sets([S | Ss], [?SET_OF(Type) | Types], L) ->
+ tuple_of_sets(Ss, Types, [?SET(S, Type) | L]);
+tuple_of_sets([S | Ss], [Type | Types], L) ->
+ tuple_of_sets(Ss, Types, [?ORDSET(S, Type) | L]);
+tuple_of_sets([], [], L) ->
+ list_to_tuple(reverse(L)).
+
+spec([E | Es], Fun, Type, L) ->
+ case Fun(term2set(E, Type)) of
+ true ->
+ spec(Es, Fun, Type, [E | L]);
+ false ->
+ spec(Es, Fun, Type, L);
+ _ ->
+ badarg
+ end;
+spec([], _Fun, _Type, L) ->
+ reverse(L).
+
+specification([E | Es], Fun, L) ->
+ case Fun(E) of
+ true ->
+ specification(Es, Fun, [E | L]);
+ false ->
+ specification(Es, Fun, L);
+ _ ->
+ badarg
+ end;
+specification([], _Fun, L) ->
+ reverse(L).
+
+%% Elements from the first list are kept.
+intersection([H1 | T1], [H2 | T2], L) when H1 < H2 ->
+ intersection1(T1, T2, L, H2);
+intersection([H1 | T1], [H2 | T2], L) when H1 == H2 ->
+ intersection(T1, T2, [H1 | L]);
+intersection([H1 | T1], [_H2 | T2], L) ->
+ intersection2(T1, T2, L, H1);
+intersection(_, _, L) ->
+ reverse(L).
+
+intersection1([H1 | T1], T2, L, H2) when H1 < H2 ->
+ intersection1(T1, T2, L, H2);
+intersection1([H1 | T1], T2, L, H2) when H1 == H2 ->
+ intersection(T1, T2, [H1 | L]);
+intersection1([H1 | T1], T2, L, _H2) ->
+ intersection2(T1, T2, L, H1);
+intersection1(_, _, L, _) ->
+ reverse(L).
+
+intersection2(T1, [H2 | T2], L, H1) when H1 > H2 ->
+ intersection2(T1, T2, L, H1);
+intersection2(T1, [H2 | T2], L, H1) when H1 == H2 ->
+ intersection(T1, T2, [H1 | L]);
+intersection2(T1, [H2 | T2], L, _H1) ->
+ intersection1(T1, T2, L, H2);
+intersection2(_, _, L, _) ->
+ reverse(L).
+
+difference([H1 | T1], [H2 | T2], L) when H1 < H2 ->
+ diff(T1, T2, [H1 | L], H2);
+difference([H1 | T1], [H2 | T2], L) when H1 == H2 ->
+ difference(T1, T2, L);
+difference([H1 | T1], [_H2 | T2], L) ->
+ diff2(T1, T2, L, H1);
+difference(L1, _, L) ->
+ reverse(L, L1).
+
+diff([H1 | T1], T2, L, H2) when H1 < H2 ->
+ diff(T1, T2, [H1 | L], H2);
+diff([H1 | T1], T2, L, H2) when H1 == H2 ->
+ difference(T1, T2, L);
+diff([H1 | T1], T2, L, _H2) ->
+ diff2(T1, T2, L, H1);
+diff(_, _, L, _) ->
+ reverse(L).
+
+diff2(T1, [H2 | T2], L, H1) when H1 > H2 ->
+ diff2(T1, T2, L, H1);
+diff2(T1, [H2 | T2], L, H1) when H1 == H2 ->
+ difference(T1, T2, L);
+diff2(T1, [H2 | T2], L, H1) ->
+ diff(T1, T2, [H1 | L], H2);
+diff2(T1, _, L, H1) ->
+ reverse(L, [H1 | T1]).
+
+symdiff([H1 | T1], T2, L) ->
+ symdiff2(T1, T2, L, H1);
+symdiff(_, T2, L) ->
+ reverse(L, T2).
+
+symdiff1([H1 | T1], T2, L, H2) when H1 < H2 ->
+ symdiff1(T1, T2, [H1 | L], H2);
+symdiff1([H1 | T1], T2, L, H2) when H1 == H2 ->
+ symdiff(T1, T2, L);
+symdiff1([H1 | T1], T2, L, H2) ->
+ symdiff2(T1, T2, [H2 | L], H1);
+symdiff1(_, T2, L, H2) ->
+ reverse(L, [H2 | T2]).
+
+symdiff2(T1, [H2 | T2], L, H1) when H1 > H2 ->
+ symdiff2(T1, T2, [H2 | L], H1);
+symdiff2(T1, [H2 | T2], L, H1) when H1 == H2 ->
+ symdiff(T1, T2, L);
+symdiff2(T1, [H2 | T2], L, H1) ->
+ symdiff1(T1, T2, [H1 | L], H2);
+symdiff2(T1, _, L, H1) ->
+ reverse(L, [H1 | T1]).
+
+sympart([H1 | T1], [H2 | T2], L1, L12, L2, T) when H1 < H2 ->
+ sympart1(T1, T2, [H1 | L1], L12, L2, T, H2);
+sympart([H1 | T1], [H2 | T2], L1, L12, L2, T) when H1 == H2 ->
+ sympart(T1, T2, L1, [H1 | L12], L2, T);
+sympart([H1 | T1], [H2 | T2], L1, L12, L2, T) ->
+ sympart2(T1, T2, L1, L12, [H2 | L2], T, H1);
+sympart(S1, [], L1, L12, L2, T) ->
+ {?SET(reverse(L1, S1), T),
+ ?SET(reverse(L12), T),
+ ?SET(reverse(L2), T)};
+sympart(_, S2, L1, L12, L2, T) ->
+ {?SET(reverse(L1), T),
+ ?SET(reverse(L12), T),
+ ?SET(reverse(L2, S2), T)}.
+
+sympart1([H1 | T1], T2, L1, L12, L2, T, H2) when H1 < H2 ->
+ sympart1(T1, T2, [H1 | L1], L12, L2, T, H2);
+sympart1([H1 | T1], T2, L1, L12, L2, T, H2) when H1 == H2 ->
+ sympart(T1, T2, L1, [H1 | L12], L2, T);
+sympart1([H1 | T1], T2, L1, L12, L2, T, H2) ->
+ sympart2(T1, T2, L1, L12, [H2 | L2], T, H1);
+sympart1(_, T2, L1, L12, L2, T, H2) ->
+ {?SET(reverse(L1), T),
+ ?SET(reverse(L12), T),
+ ?SET(reverse(L2, [H2 | T2]), T)}.
+
+sympart2(T1, [H2 | T2], L1, L12, L2, T, H1) when H1 > H2 ->
+ sympart2(T1, T2, L1, L12, [H2 | L2], T, H1);
+sympart2(T1, [H2 | T2], L1, L12, L2, T, H1) when H1 == H2 ->
+ sympart(T1, T2, L1, [H1 | L12], L2, T);
+sympart2(T1, [H2 | T2], L1, L12, L2, T, H1) ->
+ sympart1(T1, T2, [H1 | L1], L12, L2, T, H2);
+sympart2(T1, _, L1, L12, L2, T, H1) ->
+ {?SET(reverse(L1, [H1 | T1]), T),
+ ?SET(reverse(L12), T),
+ ?SET(reverse(L2), T)}.
+
+prod([[E | Es] | Xs], T, L) ->
+ prod(Es, Xs, T, prod(Xs, [E | T], L));
+prod([], T, L) ->
+ [list_to_tuple(reverse(T)) | L].
+
+prod([E | Es], Xs, T, L) ->
+ prod(Es, Xs, T, prod(Xs, [E | T], L));
+prod([], _Xs, _E, L) ->
+ L.
+
+constant_function([E | Es], X, L) ->
+ constant_function(Es, X, [{E,X} | L]);
+constant_function([], _X, L) ->
+ reverse(L).
+
+subset([H1 | T1], [H2 | T2]) when H1 > H2 ->
+ subset(T1, T2, H1);
+subset([H1 | T1], [H2 | T2]) when H1 == H2 ->
+ subset(T1, T2);
+subset(L1, _) ->
+ L1 =:= [].
+
+subset(T1, [H2 | T2], H1) when H1 > H2 ->
+ subset(T1, T2, H1);
+subset(T1, [H2 | T2], H1) when H1 == H2 ->
+ subset(T1, T2);
+subset(_, _, _) ->
+ false.
+
+disjoint([B | Bs], A, As) when A < B ->
+ disjoint(As, B, Bs);
+disjoint([B | _Bs], A, _As) when A == B ->
+ false;
+disjoint([_B | Bs], A, As) ->
+ disjoint(Bs, A, As);
+disjoint(_Bs, _A, _As) ->
+ true.
+
+%% Append sets that come in order, then "merge".
+lunion([[_] = S]) -> % optimization
+ S;
+lunion([[] | Ls]) ->
+ lunion(Ls);
+lunion([S | Ss]) ->
+ umerge(lunion(Ss, last(S), [S], []));
+lunion([]) ->
+ [].
+
+lunion([[E] = S | Ss], Last, SL, Ls) when E > Last -> % optimization
+ lunion(Ss, E, [S | SL], Ls);
+lunion([S | Ss], Last, SL, Ls) when hd(S) > Last ->
+ lunion(Ss, last(S), [S | SL], Ls);
+lunion([S | Ss], _Last, SL, Ls) ->
+ lunion(Ss, last(S), [S], [append(reverse(SL)) | Ls]);
+lunion([], _Last, SL, Ls) ->
+ [append(reverse(SL)) | Ls].
+
+%% The empty list is always the first list, if present.
+lintersection(_, []) ->
+ [];
+lintersection([S | Ss], S0) ->
+ lintersection(Ss, intersection(S, S0, []));
+lintersection([], S) ->
+ S.
+
+can_rel([S | Ss], L) ->
+ can_rel(Ss, L, S, S);
+can_rel([], L) ->
+ sort(L).
+
+can_rel(Ss, L, [E | Es], S) ->
+ can_rel(Ss, [{E, S} | L], Es, S);
+can_rel(Ss, L, _, _S) ->
+ can_rel(Ss, L).
+
+rel2family([{X,Y} | S]) ->
+ rel2fam(S, X, [Y], []);
+rel2family([]) ->
+ [].
+
+rel2fam([{X,Y} | S], X0, YL, L) when X0 == X ->
+ rel2fam(S, X0, [Y | YL], L);
+rel2fam([{X,Y} | S], X0, [A,B | YL], L) -> % optimization
+ rel2fam(S, X, [Y], [{X0,reverse(YL,[B,A])} | L]);
+rel2fam([{X,Y} | S], X0, YL, L) ->
+ rel2fam(S, X, [Y], [{X0,YL} | L]);
+rel2fam([], X, YL, L) ->
+ reverse([{X,reverse(YL)} | L]).
+
+dom([{X,_} | Es]) ->
+ dom([], X, Es);
+dom([] = L) ->
+ L.
+
+dom(L, X, [{X1,_} | Es]) when X == X1 ->
+ dom(L, X, Es);
+dom(L, X, [{Y,_} | Es]) ->
+ dom([X | L], Y, Es);
+dom(L, X, []) ->
+ reverse(L, [X]).
+
+ran([{_,Y} | Es], L) ->
+ ran(Es, [Y | L]);
+ran([], L) ->
+ usort(L).
+
+relprod(A, B) ->
+ usort(relprod1(A, B)).
+
+relprod1([{Ay,Ax} | A], B) ->
+ relprod1(B, Ay, Ax, A, []);
+relprod1(_A, _B) ->
+ [].
+
+relprod1([{Bx,_By} | B], Ay, Ax, A, L) when Ay > Bx ->
+ relprod1(B, Ay, Ax, A, L);
+relprod1([{Bx,By} | B], Ay, Ax, A, L) when Ay == Bx ->
+ relprod(B, Bx, By, A, [{Ax,By} | L], Ax, B, Ay);
+relprod1([{Bx,By} | B], _Ay, _Ax, A, L) ->
+ relprod2(B, Bx, By, A, L);
+relprod1(_B, _Ay, _Ax, _A, L) ->
+ L.
+
+relprod2(B, Bx, By, [{Ay, _Ax} | A], L) when Ay < Bx ->
+ relprod2(B, Bx, By, A, L);
+relprod2(B, Bx, By, [{Ay, Ax} | A], L) when Ay == Bx ->
+ relprod(B, Bx, By, A, [{Ax,By} | L], Ax, B, Ay);
+relprod2(B, _Bx, _By, [{Ay, Ax} | A], L) ->
+ relprod1(B, Ay, Ax, A, L);
+relprod2(_, _, _, _, L) ->
+ L.
+
+relprod(B0, Bx0, By0, A0, L, Ax, [{Bx,By} | B], Ay) when Ay == Bx ->
+ relprod(B0, Bx0, By0, A0, [{Ax,By} | L], Ax, B, Ay);
+relprod(B0, Bx0, By0, A0, L, _Ax, _B, _Ay) ->
+ relprod2(B0, Bx0, By0, A0, L).
+
+relprod_n([], _R, _EmptyG, _IsR) ->
+ {error, badarg};
+relprod_n(RL, R, EmptyR, IsR) ->
+ case domain_type(RL, ?ANYTYPE) of
+ Error = {error, _Reason} ->
+ Error;
+ DType ->
+ Empty = any(fun is_empty_set/1, RL) or EmptyR,
+ RType = range_type(RL, []),
+ Type = ?BINREL(DType, RType),
+ Prod =
+ case Empty of
+ true when DType =:= ?ANYTYPE; RType =:= ?ANYTYPE ->
+ empty_set();
+ true ->
+ ?SET([], Type);
+ false ->
+ TL = ?LIST((relprod_n(RL))),
+ Sz = length(RL),
+ Fun = fun({X,A}) -> {X, flat(Sz, A, [])} end,
+ ?SET(map(Fun, TL), Type)
+ end,
+ case IsR of
+ true -> relative_product(Prod, R);
+ false -> Prod
+ end
+ end.
+
+relprod_n([R | Rs]) ->
+ relprod_n(Rs, R).
+
+relprod_n([], R) ->
+ R;
+relprod_n([R | Rs], R0) ->
+ T = raise_element(R0, 1),
+ R1 = relative_product1(T, R),
+ NR = projection({external, fun({{X,A},AS}) -> {X,{A,AS}} end}, R1),
+ relprod_n(Rs, NR).
+
+flat(1, A, L) ->
+ list_to_tuple([A | L]);
+flat(N, {T,A}, L) ->
+ flat(N-1, T, [A | L]).
+
+domain_type([T | Ts], T0) when ?IS_SET(T) ->
+ case ?TYPE(T) of
+ ?BINREL(DT, _RT) ->
+ case unify_types(DT, T0) of
+ [] -> {error, type_mismatch};
+ T1 -> domain_type(Ts, T1)
+ end;
+ ?ANYTYPE ->
+ domain_type(Ts, T0);
+ _ -> {error, badarg}
+ end;
+domain_type([], T0) ->
+ T0.
+
+range_type([T | Ts], L) ->
+ case ?TYPE(T) of
+ ?BINREL(_DT, RT) ->
+ range_type(Ts, [RT | L]);
+ ?ANYTYPE ->
+ ?ANYTYPE
+ end;
+range_type([], L) ->
+ list_to_tuple(reverse(L)).
+
+converse([{A,B} | X], L) ->
+ converse(X, [{B,A} | L]);
+converse([], L) ->
+ sort(L).
+
+strict([{E1,E2} | Es], L) when E1 == E2 ->
+ strict(Es, L);
+strict([E | Es], L) ->
+ strict(Es, [E | L]);
+strict([], L) ->
+ reverse(L).
+
+weak(Es) ->
+ %% Not very efficient...
+ weak(Es, ran(Es, []), []).
+
+weak(Es=[{X,_} | _], [Y | Ys], L) when X > Y ->
+ weak(Es, Ys, [{Y,Y} | L]);
+weak(Es=[{X,_} | _], [Y | Ys], L) when X == Y ->
+ weak(Es, Ys, L);
+weak([E={X,Y} | Es], Ys, L) when X > Y ->
+ weak1(Es, Ys, [E | L], X);
+weak([E={X,Y} | Es], Ys, L) when X == Y ->
+ weak2(Es, Ys, [E | L], X);
+weak([E={X,_Y} | Es], Ys, L) -> % when X < _Y
+ weak2(Es, Ys, [E, {X,X} | L], X);
+weak([], [Y | Ys], L) ->
+ weak([], Ys, [{Y,Y} | L]);
+weak([], [], L) ->
+ reverse(L).
+
+weak1([E={X,Y} | Es], Ys, L, X0) when X > Y, X == X0 ->
+ weak1(Es, Ys, [E | L], X);
+weak1([E={X,Y} | Es], Ys, L, X0) when X == Y, X == X0 ->
+ weak2(Es, Ys, [E | L], X);
+weak1([E={X,_Y} | Es], Ys, L, X0) when X == X0 -> % when X < Y
+ weak2(Es, Ys, [E, {X,X} | L], X);
+weak1(Es, Ys, L, X) ->
+ weak(Es, Ys, [{X,X} | L]).
+
+weak2([E={X,_Y} | Es], Ys, L, X0) when X == X0 -> % when X < _Y
+ weak2(Es, Ys, [E | L], X);
+weak2(Es, Ys, L, _X) ->
+ weak(Es, Ys, L).
+
+extc(L, [D | Ds], C, Ts) ->
+ extc(L, Ds, C, Ts, D);
+extc(L, [], _C, _Ts) ->
+ L.
+
+extc(L, Ds, C, [{X,_Y} | Ts], D) when X < D ->
+ extc(L, Ds, C, Ts, D);
+extc(L, Ds, C, [{X,_Y} | Ts], D) when X == D ->
+ extc(L, Ds, C, Ts);
+extc(L, Ds, C, [{X,_Y} | Ts], D) ->
+ extc2([{D,C} | L], Ds, C, Ts, X);
+extc(L, Ds, C, [], D) ->
+ extc_tail([{D,C} | L], Ds, C).
+
+extc2(L, [D | Ds], C, Ts, X) when X > D ->
+ extc2([{D,C} | L], Ds, C, Ts, X);
+extc2(L, [D | Ds], C, Ts, X) when X == D ->
+ extc(L, Ds, C, Ts);
+extc2(L, [D | Ds], C, Ts, _X) ->
+ extc(L, Ds, C, Ts, D);
+extc2(L, [], _C, _Ts, _X) ->
+ L.
+
+extc_tail(L, [D | Ds], C) ->
+ extc_tail([{D,C} | L], Ds, C);
+extc_tail(L, [], _C) ->
+ L.
+
+is_a_func([{E,_} | Es], E0) when E /= E0 ->
+ is_a_func(Es, E);
+is_a_func(L, _E) ->
+ L =:= [].
+
+restrict_n(I, [T | Ts], Key, Keys, L) ->
+ case element(I, T) of
+ K when K < Key ->
+ restrict_n(I, Ts, Key, Keys, L);
+ K when K == Key ->
+ restrict_n(I, Ts, Key, Keys, [T | L]);
+ K ->
+ restrict_n(I, K, Ts, Keys, L, T)
+ end;
+restrict_n(_I, _Ts, _Key, _Keys, L) ->
+ L.
+
+restrict_n(I, K, Ts, [Key | Keys], L, E) when K > Key ->
+ restrict_n(I, K, Ts, Keys, L, E);
+restrict_n(I, K, Ts, [Key | Keys], L, E) when K == Key ->
+ restrict_n(I, Ts, Key, Keys, [E | L]);
+restrict_n(I, _K, Ts, [Key | Keys], L, _E) ->
+ restrict_n(I, Ts, Key, Keys, L);
+restrict_n(_I, _K, _Ts, _Keys, L, _E) ->
+ L.
+
+restrict([Key | Keys], Tuples) ->
+ restrict(Tuples, Key, Keys, []);
+restrict(_Keys, _Tuples) ->
+ [].
+
+restrict([{K,_E} | Ts], Key, Keys, L) when K < Key ->
+ restrict(Ts, Key, Keys, L);
+restrict([{K,E} | Ts], Key, Keys, L) when K == Key ->
+ restrict(Ts, Key, Keys, [E | L]);
+restrict([{K,E} | Ts], _Key, Keys, L) ->
+ restrict(Ts, K, Keys, L, E);
+restrict(_Ts, _Key, _Keys, L) ->
+ L.
+
+restrict(Ts, K, [Key | Keys], L, E) when K > Key ->
+ restrict(Ts, K, Keys, L, E);
+restrict(Ts, K, [Key | Keys], L, E) when K == Key ->
+ restrict(Ts, Key, Keys, [E | L]);
+restrict(Ts, _K, [Key | Keys], L, _E) ->
+ restrict(Ts, Key, Keys, L);
+restrict(_Ts, _K, _Keys, L, _E) ->
+ L.
+
+diff_restrict_n(I, [T | Ts], Key, Keys, L) ->
+ case element(I, T) of
+ K when K < Key ->
+ diff_restrict_n(I, Ts, Key, Keys, [T | L]);
+ K when K == Key ->
+ diff_restrict_n(I, Ts, Key, Keys, L);
+ K ->
+ diff_restrict_n(I, K, Ts, Keys, L, T)
+ end;
+diff_restrict_n(I, _Ts, _Key, _Keys, L) when I =:= 1 ->
+ reverse(L);
+diff_restrict_n(_I, _Ts, _Key, _Keys, L) ->
+ sort(L).
+
+diff_restrict_n(I, K, Ts, [Key | Keys], L, T) when K > Key ->
+ diff_restrict_n(I, K, Ts, Keys, L, T);
+diff_restrict_n(I, K, Ts, [Key | Keys], L, _T) when K == Key ->
+ diff_restrict_n(I, Ts, Key, Keys, L);
+diff_restrict_n(I, _K, Ts, [Key | Keys], L, T) ->
+ diff_restrict_n(I, Ts, Key, Keys, [T | L]);
+diff_restrict_n(I, _K, Ts, _Keys, L, T) when I =:= 1 ->
+ reverse(L, [T | Ts]);
+diff_restrict_n(_I, _K, Ts, _Keys, L, T) ->
+ sort([T | Ts ++ L]).
+
+diff_restrict([Key | Keys], Tuples) ->
+ diff_restrict(Tuples, Key, Keys, []);
+diff_restrict(_Keys, Tuples) ->
+ diff_restrict_tail(Tuples, []).
+
+diff_restrict([{K,E} | Ts], Key, Keys, L) when K < Key ->
+ diff_restrict(Ts, Key, Keys, [E | L]);
+diff_restrict([{K,_E} | Ts], Key, Keys, L) when K == Key ->
+ diff_restrict(Ts, Key, Keys, L);
+diff_restrict([{K,E} | Ts], _Key, Keys, L) ->
+ diff_restrict(Ts, K, Keys, L, E);
+diff_restrict(_Ts, _Key, _Keys, L) ->
+ L.
+
+diff_restrict(Ts, K, [Key | Keys], L, E) when K > Key ->
+ diff_restrict(Ts, K, Keys, L, E);
+diff_restrict(Ts, K, [Key | Keys], L, _E) when K == Key ->
+ diff_restrict(Ts, Key, Keys, L);
+diff_restrict(Ts, _K, [Key | Keys], L, E) ->
+ diff_restrict(Ts, Key, Keys, [E | L]);
+diff_restrict(Ts, _K, _Keys, L, E) ->
+ diff_restrict_tail(Ts, [E | L]).
+
+diff_restrict_tail([{_K,E} | Ts], L) ->
+ diff_restrict_tail(Ts, [E | L]);
+diff_restrict_tail(_Ts, L) ->
+ L.
+
+comp([], B) ->
+ check_function(B, []);
+comp(_A, []) ->
+ bad_function;
+comp(A0, [{Bx,By} | B]) ->
+ A = converse(A0, []),
+ check_function(A0, comp1(A, B, [], Bx, By)).
+
+comp1([{Ay,Ax} | A], B, L, Bx, By) when Ay == Bx ->
+ comp1(A, B, [{Ax,By} | L], Bx, By);
+comp1([{Ay,Ax} | A], B, L, Bx, _By) when Ay > Bx ->
+ comp2(A, B, L, Bx, Ay, Ax);
+comp1([{Ay,_Ax} | _A], _B, _L, Bx, _By) when Ay < Bx ->
+ bad_function;
+comp1([], B, L, Bx, _By) ->
+ check_function(Bx, B, L).
+
+comp2(A, [{Bx,_By} | B], L, Bx0, Ay, Ax) when Ay > Bx, Bx /= Bx0 ->
+ comp2(A, B, L, Bx, Ay, Ax);
+comp2(A, [{Bx,By} | B], L, _Bx0, Ay, Ax) when Ay == Bx ->
+ comp1(A, B, [{Ax,By} | L], Bx, By);
+comp2(_A, _B, _L, _Bx0, _Ay, _Ax) ->
+ bad_function.
+
+inverse1([{A,B} | X]) ->
+ inverse(X, A, [{B,A}]);
+inverse1([]) ->
+ [].
+
+inverse([{A,B} | X], A0, L) when A0 /= A ->
+ inverse(X, A, [{B,A} | L]);
+inverse([{A,_B} | _X], A0, _L) when A0 == A ->
+ bad_function;
+inverse([], _A0, L) ->
+ SL = [{V,_} | Es] = sort(L),
+ case is_a_func(Es, V) of
+ true -> SL;
+ false -> bad_function
+ end.
+
+%% Inlined.
+external_fun({external, Function}) when is_atom(Function) ->
+ false;
+external_fun({external, Fun}) ->
+ Fun;
+external_fun(_) ->
+ false.
+
+%% Inlined.
+element_type(?SET_OF(Type)) -> Type;
+element_type(Type) -> Type.
+
+subst(Ts, Fun, Type) ->
+ subst(Ts, Fun, Type, ?ANYTYPE, []).
+
+subst([T | Ts], Fun, Type, NType, L) ->
+ case setfun(T, Fun, Type, NType) of
+ {SD, ST} -> subst(Ts, Fun, Type, ST, [{T, SD} | L]);
+ Bad -> Bad
+ end;
+subst([], _Fun, _Type, NType, L) ->
+ {L, NType}.
+
+projection1([E | Es]) ->
+ projection1([], element(1, E), Es);
+projection1([] = L) ->
+ L.
+
+projection1(L, X, [E | Es]) ->
+ case element(1, E) of
+ X1 when X == X1 -> projection1(L, X, Es);
+ X1 -> projection1([X | L], X1, Es)
+ end;
+projection1(L, X, []) ->
+ reverse(L, [X]).
+
+projection_n([E | Es], I, L) ->
+ projection_n(Es, I, [element(I, E) | L]);
+projection_n([], _I, L) ->
+ usort(L).
+
+substitute_element([T | Ts], I, L) ->
+ substitute_element(Ts, I, [{T, element(I, T)} | L]);
+substitute_element(_, _I, L) ->
+ reverse(L).
+
+substitute([T | Ts], Fun, L) ->
+ substitute(Ts, Fun, [{T, Fun(T)} | L]);
+substitute(_, _Fun, L) ->
+ reverse(L).
+
+partition_n(I, [E | Ts]) ->
+ partition_n(I, Ts, element(I, E), [E], []);
+partition_n(_I, []) ->
+ [].
+
+partition_n(I, [E | Ts], K, Es, P) ->
+ case {element(I, E), Es} of
+ {K1, _} when K == K1 ->
+ partition_n(I, Ts, K, [E | Es], P);
+ {K1, [_]} -> % optimization
+ partition_n(I, Ts, K1, [E], [Es | P]);
+ {K1, _} ->
+ partition_n(I, Ts, K1, [E], [reverse(Es) | P])
+ end;
+partition_n(I, [], _K, Es, P) when I > 1 ->
+ sort([reverse(Es) | P]);
+partition_n(_I, [], _K, [_] = Es, P) -> % optimization
+ reverse(P, [Es]);
+partition_n(_I, [], _K, Es, P) ->
+ reverse(P, [reverse(Es)]).
+
+partition3_n(I, [T | Ts], Key, Keys, L1, L2) ->
+ case element(I, T) of
+ K when K < Key ->
+ partition3_n(I, Ts, Key, Keys, L1, [T | L2]);
+ K when K == Key ->
+ partition3_n(I, Ts, Key, Keys, [T | L1], L2);
+ K ->
+ partition3_n(I, K, Ts, Keys, L1, L2, T)
+ end;
+partition3_n(I, _Ts, _Key, _Keys, L1, L2) when I =:= 1 ->
+ [reverse(L1) | reverse(L2)];
+partition3_n(_I, _Ts, _Key, _Keys, L1, L2) ->
+ [sort(L1) | sort(L2)].
+
+partition3_n(I, K, Ts, [Key | Keys], L1, L2, T) when K > Key ->
+ partition3_n(I, K, Ts, Keys, L1, L2, T);
+partition3_n(I, K, Ts, [Key | Keys], L1, L2, T) when K == Key ->
+ partition3_n(I, Ts, Key, Keys, [T | L1], L2);
+partition3_n(I, _K, Ts, [Key | Keys], L1, L2, T) ->
+ partition3_n(I, Ts, Key, Keys, L1, [T | L2]);
+partition3_n(I, _K, Ts, _Keys, L1, L2, T) when I =:= 1 ->
+ [reverse(L1) | reverse(L2, [T | Ts])];
+partition3_n(_I, _K, Ts, _Keys, L1, L2, T) ->
+ [sort(L1) | sort([T | Ts ++ L2])].
+
+partition3([Key | Keys], Tuples) ->
+ partition3(Tuples, Key, Keys, [], []);
+partition3(_Keys, Tuples) ->
+ partition3_tail(Tuples, [], []).
+
+partition3([{K,E} | Ts], Key, Keys, L1, L2) when K < Key ->
+ partition3(Ts, Key, Keys, L1, [E | L2]);
+partition3([{K,E} | Ts], Key, Keys, L1, L2) when K == Key ->
+ partition3(Ts, Key, Keys, [E | L1], L2);
+partition3([{K,E} | Ts], _Key, Keys, L1, L2) ->
+ partition3(Ts, K, Keys, L1, L2, E);
+partition3(_Ts, _Key, _Keys, L1, L2) ->
+ [L1 | L2].
+
+partition3(Ts, K, [Key | Keys], L1, L2, E) when K > Key ->
+ partition3(Ts, K, Keys, L1, L2, E);
+partition3(Ts, K, [Key | Keys], L1, L2, E) when K == Key ->
+ partition3(Ts, Key, Keys, [E | L1], L2);
+partition3(Ts, _K, [Key | Keys], L1, L2, E) ->
+ partition3(Ts, Key, Keys, L1, [E | L2]);
+partition3(Ts, _K, _Keys, L1, L2, E) ->
+ partition3_tail(Ts, L1, [E | L2]).
+
+partition3_tail([{_K,E} | Ts], L1, L2) ->
+ partition3_tail(Ts, L1, [E | L2]);
+partition3_tail(_Ts, L1, L2) ->
+ [L1 | L2].
+
+replace([E | Es], F, L) ->
+ replace(Es, F, [F(E) | L]);
+replace(_, _F, L) ->
+ sort(L).
+
+mul_relprod([T | Ts], I, R) when ?IS_SET(T) ->
+ P = raise_element(R, I),
+ F = relative_product1(P, T),
+ [F | mul_relprod(Ts, I+1, R)];
+mul_relprod([], _I, _R) ->
+ [].
+
+raise_element(R, I) ->
+ L = sort(I =/= 1, rearr(?LIST(R), I, [])),
+ Type = ?TYPE(R),
+ ?SET(L, ?BINREL(?REL_TYPE(I, Type), Type)).
+
+rearr([E | Es], I, L) ->
+ rearr(Es, I, [{element(I, E), E} | L]);
+rearr([], _I, L) ->
+ L.
+
+join_element(E1, E2) ->
+ [_ | L2] = tuple_to_list(E2),
+ list_to_tuple(tuple_to_list(E1) ++ L2).
+
+join_element(E1, E2, I2) ->
+ tuple_to_list(E1) ++ join_element2(tuple_to_list(E2), 1, I2).
+
+join_element2([B | Bs], C, I2) when C =/= I2 ->
+ [B | join_element2(Bs, C+1, I2)];
+join_element2([_ | Bs], _C, _I2) ->
+ Bs.
+
+family2rel([{X,S} | F], L) ->
+ fam2rel(F, L, X, S);
+family2rel([], L) ->
+ reverse(L).
+
+fam2rel(F, L, X, [Y | Ys]) ->
+ fam2rel(F, [{X,Y} | L], X, Ys);
+fam2rel(F, L, _X, _) ->
+ family2rel(F, L).
+
+fam_spec([{_,S}=E | F], Fun, Type, L) ->
+ case Fun(?SET(S, Type)) of
+ true ->
+ fam_spec(F, Fun, Type, [E | L]);
+ false ->
+ fam_spec(F, Fun, Type, L);
+ _ ->
+ badarg
+ end;
+fam_spec([], _Fun, _Type, L) ->
+ reverse(L).
+
+fam_specification([{_,S}=E | F], Fun, L) ->
+ case Fun(S) of
+ true ->
+ fam_specification(F, Fun, [E | L]);
+ false ->
+ fam_specification(F, Fun, L);
+ _ ->
+ badarg
+ end;
+fam_specification([], _Fun, L) ->
+ reverse(L).
+
+un_of_fam([{_X,S} | F], L) ->
+ un_of_fam(F, [S | L]);
+un_of_fam([], L) ->
+ lunion(sort(L)).
+
+int_of_fam([{_,S} | F]) ->
+ int_of_fam(F, [S]);
+int_of_fam([]) ->
+ badarg.
+
+int_of_fam([{_,S} | F], L) ->
+ int_of_fam(F, [S | L]);
+int_of_fam([], [L | Ls]) ->
+ lintersection(Ls, L).
+
+fam_un([{X,S} | F], L) ->
+ fam_un(F, [{X, lunion(S)} | L]);
+fam_un([], L) ->
+ reverse(L).
+
+fam_int([{X, [S | Ss]} | F], L) ->
+ fam_int(F, [{X, lintersection(Ss, S)} | L]);
+fam_int([{_X,[]} | _F], _L) ->
+ badarg;
+fam_int([], L) ->
+ reverse(L).
+
+fam_dom([{X,S} | F], L) ->
+ fam_dom(F, [{X, dom(S)} | L]);
+fam_dom([], L) ->
+ reverse(L).
+
+fam_ran([{X,S} | F], L) ->
+ fam_ran(F, [{X, ran(S, [])} | L]);
+fam_ran([], L) ->
+ reverse(L).
+
+fam_union(F1 = [{A,_AS} | _AL], [B1={B,_BS} | BL], L) when A > B ->
+ fam_union(F1, BL, [B1 | L]);
+fam_union([{A,AS} | AL], [{B,BS} | BL], L) when A == B ->
+ fam_union(AL, BL, [{A, umerge(AS, BS)} | L]);
+fam_union([A1 | AL], F2, L) ->
+ fam_union(AL, F2, [A1 | L]);
+fam_union(_, F2, L) ->
+ reverse(L, F2).
+
+fam_intersect(F1 = [{A,_AS} | _AL], [{B,_BS} | BL], L) when A > B ->
+ fam_intersect(F1, BL, L);
+fam_intersect([{A,AS} | AL], [{B,BS} | BL], L) when A == B ->
+ fam_intersect(AL, BL, [{A, intersection(AS, BS, [])} | L]);
+fam_intersect([_A1 | AL], F2, L) ->
+ fam_intersect(AL, F2, L);
+fam_intersect(_, _, L) ->
+ reverse(L).
+
+fam_difference(F1 = [{A,_AS} | _AL], [{B,_BS} | BL], L) when A > B ->
+ fam_difference(F1, BL, L);
+fam_difference([{A,AS} | AL], [{B,BS} | BL], L) when A == B ->
+ fam_difference(AL, BL, [{A, difference(AS, BS, [])} | L]);
+fam_difference([A1 | AL], F2, L) ->
+ fam_difference(AL, F2, [A1 | L]);
+fam_difference(F1, _, L) ->
+ reverse(L, F1).
+
+check_function([{X,_} | XL], R) ->
+ check_function(X, XL, R);
+check_function([], R) ->
+ R.
+
+check_function(X0, [{X,_} | XL], R) when X0 /= X ->
+ check_function(X, XL, R);
+check_function(X0, [{X,_} | _XL], _R) when X0 == X ->
+ bad_function;
+check_function(_X0, [], R) ->
+ R.
+
+fam_partition_n(I, [E | Ts]) ->
+ fam_partition_n(I, Ts, element(I, E), [E], []);
+fam_partition_n(_I, []) ->
+ [].
+
+fam_partition_n(I, [E | Ts], K, Es, P) ->
+ case {element(I, E), Es} of
+ {K1, _} when K == K1 ->
+ fam_partition_n(I, Ts, K, [E | Es], P);
+ {K1, [_]} -> % optimization
+ fam_partition_n(I, Ts, K1, [E], [{K,Es} | P]);
+ {K1, _} ->
+ fam_partition_n(I, Ts, K1, [E], [{K,reverse(Es)} | P])
+ end;
+fam_partition_n(_I, [], K, [_] = Es, P) -> % optimization
+ reverse(P, [{K,Es}]);
+fam_partition_n(_I, [], K, Es, P) ->
+ reverse(P, [{K,reverse(Es)}]).
+
+fam_partition([{K,Vs} | Ts], Sort) ->
+ fam_partition(Ts, K, [Vs], [], Sort);
+fam_partition([], _Sort) ->
+ [].
+
+fam_partition([{K1,V} | Ts], K, Vs, P, S) when K1 == K ->
+ fam_partition(Ts, K, [V | Vs], P, S);
+fam_partition([{K1,V} | Ts], K, [_] = Vs, P, S) -> % optimization
+ fam_partition(Ts, K1, [V], [{K, Vs} | P], S);
+fam_partition([{K1,V} | Ts], K, Vs, P, S) ->
+ fam_partition(Ts, K1, [V], [{K, sort(S, Vs)} | P], S);
+fam_partition([], K, [_] = Vs, P, _S) -> % optimization
+ [{K, Vs} | P];
+fam_partition([], K, Vs, P, S) ->
+ [{K, sort(S, Vs)} | P].
+
+fam_proj([{X,S} | F], Fun, Type, NType, L) ->
+ case setfun(S, Fun, Type, NType) of
+ {SD, ST} -> fam_proj(F, Fun, Type, ST, [{X, SD} | L]);
+ Bad -> Bad
+ end;
+fam_proj([], _Fun, _Type, NType, L) ->
+ {reverse(L), NType}.
+
+setfun(T, Fun, Type, NType) ->
+ case Fun(term2set(T, Type)) of
+ NS when ?IS_SET(NS) ->
+ case unify_types(NType, ?SET_OF(?TYPE(NS))) of
+ [] -> type_mismatch;
+ NT -> {?LIST(NS), NT}
+ end;
+ NS when ?IS_ORDSET(NS) ->
+ case unify_types(NType, NT = ?ORDTYPE(NS)) of
+ [] -> type_mismatch;
+ NT -> {?ORDDATA(NS), NT}
+ end;
+ _ ->
+ badarg
+ end.
+
+%% Inlined.
+term2set(L, Type) when is_list(L) ->
+ ?SET(L, Type);
+term2set(T, Type) ->
+ ?ORDSET(T, Type).
+
+fam2digraph(F, G) ->
+ Fun = fun({From, ToL}) ->
+ digraph:add_vertex(G, From),
+ Fun2 = fun(To) ->
+ digraph:add_vertex(G, To),
+ case digraph:add_edge(G, From, To) of
+ {error, {bad_edge, _}} ->
+ throw({error, cyclic});
+ _ ->
+ true
+ end
+ end,
+ foreach(Fun2, ToL)
+ end,
+ foreach(Fun, to_external(F)),
+ G.
+
+digraph_family(G) ->
+ Vs = sort(digraph:vertices(G)),
+ digraph_fam(Vs, Vs, G, []).
+
+digraph_fam([V | Vs], V0, G, L) when V /= V0 ->
+ Ns = sort(digraph:out_neighbours(G, V)),
+ digraph_fam(Vs, V, G, [{V,Ns} | L]);
+digraph_fam([], _V0, _G, L) ->
+ reverse(L).
+
+%% -> boolean()
+check_fun(T, F, FunT) ->
+ true = is_type(FunT),
+ {NT, _MaxI} = number_tuples(T, 1),
+ L = flatten(tuple2list(F(NT))),
+ has_hole(L, 1).
+
+number_tuples(T, N) when is_tuple(T) ->
+ {L, NN} = mapfoldl(fun number_tuples/2, N, tuple_to_list(T)),
+ {list_to_tuple(L), NN};
+number_tuples(_, N) ->
+ {N, N+1}.
+
+tuple2list(T) when is_tuple(T) ->
+ map(fun tuple2list/1, tuple_to_list(T));
+tuple2list(C) ->
+ [C].
+
+has_hole([I | Is], I0) when I =< I0 -> has_hole(Is, erlang:max(I+1, I0));
+has_hole(Is, _I) -> Is =/= [].
+
+%% Optimization. Same as check_fun/3, but for integers.
+check_for_sort(T, _I) when T =:= ?ANYTYPE ->
+ empty;
+check_for_sort(T, I) when ?IS_RELATION(T), I =< ?REL_ARITY(T), I >= 1 ->
+ I > 1;
+check_for_sort(_T, _I) ->
+ error.
+
+inverse_substitution(L, Fun, Sort) ->
+ %% One easily sees that the inverse of the tuples created by
+ %% applying Fun need to be sorted iff the tuples created by Fun
+ %% need to be sorted.
+ sort(Sort, fun_rearr(L, Fun, [])).
+
+fun_rearr([E | Es], Fun, L) ->
+ fun_rearr(Es, Fun, [{Fun(E), E} | L]);
+fun_rearr([], _Fun, L) ->
+ L.
+
+sets_to_list(Ss) ->
+ map(fun(S) when ?IS_SET(S) -> ?LIST(S) end, Ss).
+
+types([], L) ->
+ list_to_tuple(reverse(L));
+types([S | _Ss], _L) when ?TYPE(S) =:= ?ANYTYPE ->
+ ?ANYTYPE;
+types([S | Ss], L) ->
+ types(Ss, [?TYPE(S) | L]).
+
+%% Inlined.
+unify_types(T, T) -> T;
+unify_types(Type1, Type2) ->
+ catch unify_types1(Type1, Type2).
+
+unify_types1(Atom, Atom) when ?IS_ATOM_TYPE(Atom) ->
+ Atom;
+unify_types1(?ANYTYPE, Type) ->
+ Type;
+unify_types1(Type, ?ANYTYPE) ->
+ Type;
+unify_types1(?SET_OF(Type1), ?SET_OF(Type2)) ->
+ [unify_types1(Type1, Type2)];
+unify_types1(T1, T2) when tuple_size(T1) =:= tuple_size(T2) ->
+ unify_typesl(tuple_size(T1), T1, T2, []);
+unify_types1(_T1, _T2) ->
+ throw([]).
+
+unify_typesl(0, _T1, _T2, L) ->
+ list_to_tuple(L);
+unify_typesl(N, T1, T2, L) ->
+ T = unify_types1(?REL_TYPE(N, T1), ?REL_TYPE(N, T2)),
+ unify_typesl(N-1, T1, T2, [T | L]).
+
+%% inlined.
+match_types(T, T) -> true;
+match_types(Type1, Type2) -> match_types1(Type1, Type2).
+
+match_types1(Atom, Atom) when ?IS_ATOM_TYPE(Atom) ->
+ true;
+match_types1(?ANYTYPE, _) ->
+ true;
+match_types1(_, ?ANYTYPE) ->
+ true;
+match_types1(?SET_OF(Type1), ?SET_OF(Type2)) ->
+ match_types1(Type1, Type2);
+match_types1(T1, T2) when tuple_size(T1) =:= tuple_size(T2) ->
+ match_typesl(tuple_size(T1), T1, T2);
+match_types1(_T1, _T2) ->
+ false.
+
+match_typesl(0, _T1, _T2) ->
+ true;
+match_typesl(N, T1, T2) ->
+ case match_types1(?REL_TYPE(N, T1), ?REL_TYPE(N, T2)) of
+ true -> match_typesl(N-1, T1, T2);
+ false -> false
+ end.
+
+sort(true, L) ->
+ sort(L);
+sort(false, L) ->
+ reverse(L).
diff --git a/lib/tools/test/tools_bench.spec b/lib/tools/test/tools_bench.spec
new file mode 100644
index 0000000000..ef08fd68a8
--- /dev/null
+++ b/lib/tools/test/tools_bench.spec
@@ -0,0 +1 @@
+{suites,"../tools_test",[prof_bench_SUITE]}.
diff --git a/lib/tools/vsn.mk b/lib/tools/vsn.mk
index 5700885549..191a458c62 100644
--- a/lib/tools/vsn.mk
+++ b/lib/tools/vsn.mk
@@ -1 +1 @@
-TOOLS_VSN = 3.1
+TOOLS_VSN = 3.2
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 18:16:29 +0000