From: fabrice nicol <fabrnicol@gmail.com>
To: 47408@debbugs.gnu.org
Subject: bug#47408: Etags support for Mercury [v0.4]
Date: Mon, 29 Mar 2021 13:53:26 +0200 [thread overview]
Message-ID: <b59da901-4df7-843f-da03-5aa184d1a992@gmail.com> (raw)
In-Reply-To: <83o8f3meo8.fsf@gnu.org>
[-- Attachment #1: Type: text/plain, Size: 4484 bytes --]
Attached is the new patch that integrates your indications.
Please note two points:
1. Now that -m/-M have been done with, there is no use specifying any
Mercury-specific behavior for --no-defines.
Actually the Mercury community consensus is that all declarations should
be tagged in any case.
So --no-defines is just the default behavior of etags run without any
option and does not need to be used explicitly or specifically documented.
I followed your indications about --declarations. I also added a line to
etags.1 about --language=mercury or --language=objc, should the
heuristic test fail to detect the right language. Note, however, that
removing language-specific options comes at a price. The heuristic test
has now to be more complex. I had errless detection results against my
test base of 4,000 mercury files and 500 Obj.-C files. This looks
satisfactory but I had to tweak the heuristic test function
(test_objc_is_mercury) quite a bit to weed out detection failures.
I added the ChangeLog, the requested test file (array.m) under
test/manual/etags/merc-src and altered the corresponding Makefile
accordingly.
2. I removed by added line to speedbar.el, which in the end did not
prove very useful. It is located in a Xemacs compatibility layer that is
no longer used by most users.
Le 28/03/2021 à 18:22, Eli Zaretskii a écrit :
>> From: fabrice nicol <fabrnicol@gmail.com>
>> Date: Sun, 28 Mar 2021 17:49:20 +0200
>>
>> I left this couple of options in (following Francesco Potorti only for long options --declarations/--no-defines),
>> for two reasons:
>>
>> 1. The ambiguity between Objective C and Mercury
>>
>> Both languages having the same file extension .m, it was necessary to add in a heuristic test function, in the
>> absence of explicit language identification input from command line.
>>
>> Yet all heuristics may fail in rare cases. Tests show a fairly low failure rate on the Mercury compiler source
>> code. Less than 0.5 % of .m files are not identified as Mercury files by the test (this should have been
>> documented somewhere). File concerned by test failure are some Mercury test files and documentary test
>> files with only (or almost only) comments and blank lines.
>>
>> While this could be improved by tweaking the heuristic test, it would make it more complex, bug-prone and
>> ultimately hard to maintain.
>>
>> So -m/-M are useful to deal with these rare files, as they do not rely on the heuristic test function at all but on
>> their own semantics, which explicitly identifies Mercury.
>>
>> The only alternative I see is to explicitly warn users about adding '-l mercury' to command line when using
>> long options (in etags.1 and possibly other docs).
> I think "-l mercury" is indeed the way to tell etags this is a Mercury
> source.
>
> We never had language-specific options in etags, and I don't see a
> serious enough reason to introduce them now. I do find it unfortunate
> that Mercury uses the same extension as ObjC, but that's water under
> the bridge.
>
> Of course, if the heuristic test could be improved to make it err
> less, it would also be good.
>
>> diff --git a/lisp/speedbar.el b/lisp/speedbar.el
>> index 12e57b1108..63f3cd6ca1 100644
>> --- a/lisp/speedbar.el
>> +++ b/lisp/speedbar.el
>> @@ -3534,6 +3534,8 @@ speedbar-fetch-etags-parse-list
>> speedbar-parse-c-or-c++tag)
>> ("^\\.emacs$\\|.\\(el\\|l\\|lsp\\)\\'" .
>> "def[^i]+\\s-+\\(\\(\\w\\|[-_]\\)+\\)\\s-*\C-?")
>> + ("^\\.m$\\'" .
>> + "\\(^:-\\)?\\s-*\\(\\(pred\\|func\\|type\\|instance\\|typeclass\\)+\\s+\\([a-z]+[a-zA-Z0-9_]*\\)+\\)\\s-*(?^?")
>> ; ("\\.\\([fF]\\|for\\|FOR\\|77\\|90\\)\\'" .
>> ; speedbar-parse-fortran77-tag)
>> ("\\.tex\\'" . speedbar-parse-tex-string)
>>
>> What about ObjC here? or are these keywords good for ObjC as well?
>>
>> has the following reply: Objective C .m files are not parsed by speedbar.el in current repository code, so the
>> added feature does not break anything. Issues will only arise if/when Emacs maintainers for Objective C
>> support decide on adding this file format to the speedbar parser. It would be premature (and out-of-place)
>> for me to settle this on my own. Should this move happen, the heuristics used in etags.c (function
>> test_objc_is_mercury) could then be ported to elisp code.
> OK, so please add there a comment to say that .m is also Objective C,
> but Speedbar doesn't support it yet.
>
> Thanks.
[-- Attachment #2: 0001-Add-etags-support-for-Mercury-v0.4.patch --]
[-- Type: text/x-patch, Size: 142648 bytes --]
From a0781212917457d3569de941c80364523a422c08 Mon Sep 17 00:00:00 2001
From: Fabrice Nicol <fabrnicol@gmail.com>
Date: Mon, 29 Mar 2021 10:55:27 +0200
Subject: [PATCH] Add etags support for Mercury [v0.4]
---
doc/man/etags.1 | 23 +-
etc/NEWS | 7 +
lib-src/ChangeLog | 14 +
lib-src/etags.c | 490 +++-
test/manual/etags/Makefile | 3 +-
test/manual/etags/merc-src/array.m | 3416 ++++++++++++++++++++++++++++
6 files changed, 3940 insertions(+), 13 deletions(-)
create mode 100644 lib-src/ChangeLog
create mode 100644 test/manual/etags/merc-src/array.m
diff --git a/doc/man/etags.1 b/doc/man/etags.1
index c5c15fb182..4a908fc0a0 100644
--- a/doc/man/etags.1
+++ b/doc/man/etags.1
@@ -1,5 +1,5 @@
.\" See section COPYING for copyright and redistribution information.
-.TH ETAGS 1 "2019-06-24" "GNU Tools" "GNU"
+.TH ETAGS 1 "2021-03-30" "GNU Tools" "GNU"
.de BP
.sp
.ti -.2i
@@ -50,9 +50,9 @@ format understood by
.BR vi ( 1 )\c
\&. Both forms of the program understand
the syntax of C, Objective C, C++, Java, Fortran, Ada, Cobol, Erlang,
-Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Pascal, Perl,
-Ruby, PHP, PostScript, Python, Prolog, Scheme and
-most assembler\-like syntaxes.
+Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Mercury, Pascal,
+Perl, Ruby, PHP, PostScript, Python, Prolog, Scheme and most assembler\-like
+syntaxes.
Both forms read the files specified on the command line, and write a tag
table (defaults: \fBTAGS\fP for \fBetags\fP, \fBtags\fP for
\fBctags\fP) in the current working directory.
@@ -91,6 +91,9 @@ Only \fBctags\fP accepts this option.
In C and derived languages, create tags for function declarations,
and create tags for extern variables unless \-\-no\-globals is used.
In Lisp, create tags for (defvar foo) declarations.
+In Mercury, declarations start a line with "\|\fB:-\fP\|" and are tagged
+by default. This option also tags predicates or functions in first rules
+of clauses, as in Prolog.
.TP
.B \-D, \-\-no\-defines
Do not create tag entries for C preprocessor constant definitions
@@ -125,10 +128,14 @@ final brace of a function or structure definition in C and C++.
Parse the following files according to the given language. More than
one such options may be intermixed with filenames. Use \fB\-\-help\fP
to get a list of the available languages and their default filename
-extensions. The "auto" language can be used to restore automatic
-detection of language based on the file name. The "none"
-language may be used to disable language parsing altogether; only
-regexp matching is done in this case (see the \fB\-\-regex\fP option).
+extensions. For example, as Mercury and Objective-C have same
+filename extension \fI.m\fP, a test based on contents tries to detect
+the language. If this test fails, \fB\-\-language=\fP\fImercury\fP or
+\fB\-\-language=\fP\fIobjc\fP should be used.
+The "auto" language can be used to restore automatic detection of language
+based on the file name. The "none" language may be used to disable language
+parsing altogether; only regexp matching is done in this case (see the
+\fB\-\-regex\fP option).
.TP
.B \-\-members
Create tag entries for variables that are members of structure-like
diff --git a/etc/NEWS b/etc/NEWS
index 2d66a93474..8afb7c76b4 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -93,6 +93,13 @@ useful on systems such as FreeBSD which ships only with "etc/termcap".
\f
* Changes in Emacs 28.1
++++
+** Etags support for the Mercury programming language (https://mercurylang.org).
+** Etags command line option --declarations now has Mercury-specific behavior.
+All Mercury declarations are tagged by default.
+For compatibility with Prolog etags support, predicates and functions appearing
+first in clauses will also be tagged if etags is run with '--declarations'.
+
+++
** New command 'font-lock-update', bound to 'C-x x f'.
This command updates the syntax highlighting in this buffer.
diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog
new file mode 100644
index 0000000000..3ab71a4dab
--- /dev/null
+++ b/lib-src/ChangeLog
@@ -0,0 +1,14 @@
+Add etags support for Mercury (https://mercurylang.org)
+
+Tag declarations starting lines with ':-'.
+By default, all declarations are tagged. Optionally, first predicate or
+functions in clauses can be tagged as in Prolog support using --declarations
+(Bug#47408).
+* lib-src/etags.c (test_objc_is_mercury, Mercury_functions)
+(mercury_skip_comment, mercury_decl, mercury_pr):
+Implement Mercury support. As Mercury and Objective-C have same file extension
+.m, a heuristic test tries to detect the language.
+If this test fails, --language=mercury should be used.
+* doc/man/etags.1: Document the change. Add Mercury-specific behavior for
+--declarations. This option tags first predicates or functions in clauses in
+addition to declarations.
diff --git a/lib-src/etags.c b/lib-src/etags.c
index b5c18e0e01..a5c5224e63 100644
--- a/lib-src/etags.c
+++ b/lib-src/etags.c
@@ -142,7 +142,14 @@ Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2021 Free Software
# define CTAGS false
#endif
-/* Copy to DEST from SRC (containing LEN bytes), and append a NUL byte. */
+/* Define MERCURY_HEURISTICS_RATIO as it was necessary to disambiguate
+ Mercury from Objective C, which have same file extensions .m
+ See comments before function test_objc_is_mercury for details. */
+#ifndef MERCURY_HEURISTICS_RATIO
+# define MERCURY_HEURISTICS_RATIO 0.5
+#endif
+
+/* COPY to DEST from SRC (containing LEN bytes), and append a NUL byte. */
static void
memcpyz (void *dest, void const *src, ptrdiff_t len)
{
@@ -359,6 +366,7 @@ #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op)))
static void Lisp_functions (FILE *);
static void Lua_functions (FILE *);
static void Makefile_targets (FILE *);
+static void Mercury_functions (FILE *);
static void Pascal_functions (FILE *);
static void Perl_functions (FILE *);
static void PHP_functions (FILE *);
@@ -378,6 +386,7 @@ #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op)))
static bool nocase_tail (const char *);
static void get_tag (char *, char **);
static void get_lispy_tag (char *);
+static void test_objc_is_mercury(char *, language **);
static void analyze_regex (char *);
static void free_regexps (void);
@@ -683,10 +692,22 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */
"In makefiles, targets are tags; additionally, variables are tags\n\
unless you specify '--no-globals'.";
+/* Mercury and Objective C share the same .m file extensions. */
+static const char *Mercury_suffixes [] =
+ {"m",
+ NULL};
+static const char Mercury_help [] =
+ "In Mercury code, tags are all declarations beginning a line with ':-'\n\
+and optionally Prolog-like definitions (first rule for a predicate or \
+function).\n\
+To enable this behavior, run etags using --declarations.";
+static bool with_mercury_definitions = false;
+float mercury_heuristics_ratio = MERCURY_HEURISTICS_RATIO;
+
static const char *Objc_suffixes [] =
- { "lm", /* Objective lex file */
- "m", /* Objective C file */
- NULL };
+ { "lm", /* Objective lex file */
+ "m", /* By default, Objective C file will be assumed. */
+ NULL};
static const char Objc_help [] =
"In Objective C code, tags include Objective C definitions for classes,\n\
class categories, methods and protocols. Tags for variables and\n\
@@ -824,7 +845,9 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */
{ "lisp", Lisp_help, Lisp_functions, Lisp_suffixes },
{ "lua", Lua_help,Lua_functions,Lua_suffixes,NULL,Lua_interpreters},
{ "makefile", Makefile_help,Makefile_targets,NULL,Makefile_filenames},
+ /* objc listed before mercury as it is a better default for .m extensions. */
{ "objc", Objc_help, plain_C_entries, Objc_suffixes },
+ { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes },
{ "pascal", Pascal_help, Pascal_functions, Pascal_suffixes },
{ "perl",Perl_help,Perl_functions,Perl_suffixes,NULL,Perl_interpreters},
{ "php", PHP_help, PHP_functions, PHP_suffixes },
@@ -950,6 +973,9 @@ print_help (argument *argbuffer)
puts
("\tand create tags for extern variables unless --no-globals is used.");
+ puts ("In Mercury, tag both declarations starting a line with ':-' and first\n\
+ predicates or functions in clauses.");
+
if (CTAGS)
puts ("-d, --defines\n\
Create tag entries for C #define constants and enum constants, too.");
@@ -1775,6 +1801,11 @@ find_entries (FILE *inf)
if (parser == NULL)
{
lang = get_language_from_filename (curfdp->infname, true);
+
+ /* Disambiguate file names between Objc and Mercury */
+ if (lang != NULL && strcmp(lang->name, "objc") == 0)
+ test_objc_is_mercury(curfdp->infname, &lang);
+
if (lang != NULL && lang->function != NULL)
{
curfdp->lang = lang;
@@ -6019,6 +6050,457 @@ prolog_atom (char *s, size_t pos)
return 0;
}
+\f
+/*
+ * Support for Mercury
+ *
+ * Assumes that the declarationa starts at column 0.
+ * Original code by Sunichirou Sugou (1989) for Prolog.
+ * Rewritten by Anders Lindgren (1996) for Prolog.
+ * Adapted by Fabrice Nicol (2021) for Mercury.
+ * Note: Prolog-support behavior is preserved if
+ * --declarations is used, corresponding to
+ * with_mercury_definitions=true.
+ */
+
+static ptrdiff_t mercury_pr (char *, char *, ptrdiff_t);
+static void mercury_skip_comment (linebuffer *, FILE *);
+static bool is_mercury_type = false;
+static bool is_mercury_quantifier = false;
+static bool is_mercury_declaration = false;
+
+/*
+ * Objective-C and Mercury have identical file extension .m
+ * To disambiguate between Objective C and Mercury, parse file
+ * with the following heuristics hook:
+ * - if line starts with :- choose Mercury unconditionally,
+ * - if line starts with #, @, choose Objective-C,
+ * - otherwise compute the following ratio:
+ *
+ * r = (number of lines with :-
+ * or % in non-commented parts or . at trimmed EOL)
+ * / (number of lines - number of lines starting by any amount
+ * of whitespace, optionally followed by comment(s))
+ *
+ * Note: strings are neglected in counts.
+ *
+ * If r > mercury_heuristics_ratio, choose Mercury.
+ * Experimental tests show that a possibly optimal default value for
+ * this floor value is around 0.5. This is the default value for
+ * MERCURY_HEURISTICS_RATIO, defined in the first lines of this file.
+ * The closer r to 0.5, the closer the source code to pure Prolog.
+ * Idiomatic Mercury is scored either with r = 1.0 or higher.
+ * Objective-C is scored with r = 0.0. When this fails, the r-score never
+ * rose above 0.1 in Objective-C tests.
+ */
+
+static void
+test_objc_is_mercury (char *this_file, language **lang)
+{
+ if (this_file == NULL) return;
+ FILE* fp = fopen (this_file, "r");
+ if (fp == NULL)
+ pfatal (this_file);
+
+ bool blank_line = false; /* Line starting with any amount of white space
+ followed by optional comment(s). */
+ bool commented_line = false;
+ bool found_dot = false;
+ bool only_space_before = true;
+ bool start_of_line = true;
+ int c;
+ intmax_t lines = 1;
+ intmax_t mercury_dots = 0;
+ intmax_t percentage_signs = 0;
+ intmax_t rule_signs = 0;
+ float ratio = 0;
+
+ while ((c = fgetc (fp)) != EOF)
+ {
+ switch (c)
+ {
+ case '\n':
+ if (! blank_line) ++lines;
+ blank_line = true;
+ commented_line = false;
+ start_of_line = true;
+ if (found_dot) ++mercury_dots;
+ found_dot = false;
+ only_space_before = true;
+ break;
+ case '.':
+ found_dot = ! commented_line;
+ only_space_before = false;
+ break;
+ case '%': /* More frequent in Mercury. May be modulo in Obj.-C. */
+ if (! commented_line)
+ {
+ ++percentage_signs;
+ /* Cannot tell if it is a comment or modulo yet for sure.
+ Yet works for heuristic purposes. */
+ commented_line = true;
+ }
+ found_dot = false;
+ start_of_line = false;
+ only_space_before = false;
+ break;
+ case '/':
+ {
+ int d = fgetc(fp);
+ found_dot = false;
+ only_space_before = false;
+ if (! commented_line)
+ {
+ if (d == '*')
+ commented_line = true;
+ else
+ /* If d == '/', cannot tell if it is an Obj.-C comment:
+ may be Mercury integ. division. */
+ blank_line = false;
+ }
+ }
+ FALLTHROUGH;
+ case ' ':
+ case '\t':
+ start_of_line = false;
+ break;
+ case ':':
+ c = fgetc(fp);
+ if (start_of_line)
+ {
+ if (c == '-')
+ {
+ ratio = 1.0; /* Failsafe, not an operator in Obj.-C. */
+ goto out;
+ }
+ start_of_line = false;
+ }
+ else
+ {
+ /* p :- q. Frequent in Mercury.
+ Rare or in quoted exprs in Obj.-C. */
+ if (c == '-' && ! commented_line)
+ ++rule_signs;
+ }
+ blank_line = false;
+ found_dot = false;
+ only_space_before = false;
+ break;
+ case '@':
+ case '#':
+ if (start_of_line || only_space_before)
+ {
+ ratio = 0.0;
+ goto out;
+ }
+ FALLTHROUGH;
+ default:
+ start_of_line = false;
+ blank_line = false;
+ found_dot = false;
+ only_space_before = false;
+ }
+ }
+
+ /* Fallback heuristic test. Not failsafe but errless in pratice. */
+ ratio = ((float) rule_signs + percentage_signs + mercury_dots) / lines;
+
+ out:
+ if (fclose(fp) == EOF)
+ pfatal(this_file);
+
+ if (ratio > mercury_heuristics_ratio)
+ {
+ /* Change the language from Objective C to Mercury. */
+ static language lang0 = { "mercury", Mercury_help, Mercury_functions,
+ Mercury_suffixes };
+ *lang = &lang0;
+ }
+}
+
+static void
+Mercury_functions (FILE *inf)
+{
+ char *cp, *last = NULL;
+ ptrdiff_t lastlen = 0, allocated = 0;
+ if (declarations) with_mercury_definitions = true;
+
+ LOOP_ON_INPUT_LINES (inf, lb, cp)
+ {
+ if (cp[0] == '\0') /* Empty line. */
+ continue;
+ else if (c_isspace (cp[0]) || cp[0] == '%')
+ /* A Prolog-type comment or anything other than a declaration. */
+ continue;
+ else if (cp[0] == '/' && cp[1] == '*') /* Mercury C-type comment. */
+ mercury_skip_comment (&lb, inf);
+ else
+ {
+ is_mercury_declaration = (cp[0] == ':' && cp[1] == '-');
+
+ if (is_mercury_declaration
+ || with_mercury_definitions)
+ {
+ ptrdiff_t len = mercury_pr (cp, last, lastlen);
+ if (0 < len)
+ {
+ /* Store the declaration to avoid generating duplicate
+ tags later. */
+ if (allocated <= len)
+ {
+ xrnew (last, len + 1, 1);
+ allocated = len + 1;
+ }
+ memcpyz (last, cp, len);
+ lastlen = len;
+ }
+ }
+ }
+ }
+ free (last);
+}
+
+static void
+mercury_skip_comment (linebuffer *plb, FILE *inf)
+{
+ char *cp;
+
+ do
+ {
+ for (cp = plb->buffer; *cp != '\0'; ++cp)
+ if (cp[0] == '*' && cp[1] == '/')
+ return;
+ readline (plb, inf);
+ }
+ while (perhaps_more_input (inf));
+}
+
+/*
+ * A declaration is added if it matches:
+ * <beginning of line>:-<whitespace><Mercury Term><whitespace>(
+ * If with_mercury_definitions == true, we also add:
+ * <beginning of line><Mercury item><whitespace>(
+ * or <beginning of line><Mercury item><whitespace>:-
+ * As for Prolog support, different arities and types are not taken into
+ * consideration.
+ * Item is added to the tags database if it doesn't match the
+ * name of the previous declaration.
+ *
+ * Consume a Mercury declaration.
+ * Return the number of bytes consumed, or 0 if there was an error.
+ *
+ * A Mercury declaration must be one of:
+ * :- type
+ * :- solver type
+ * :- pred
+ * :- func
+ * :- inst
+ * :- mode
+ * :- typeclass
+ * :- instance
+ * :- pragma
+ * :- promise
+ * :- initialise
+ * :- finalise
+ * :- mutable
+ * :- module
+ * :- interface
+ * :- implementation
+ * :- import_module
+ * :- use_module
+ * :- include_module
+ * :- end_module
+ * followed on the same line by an alphanumeric sequence, starting with a lower
+ * case letter or by a single-quoted arbitrary string.
+ * Single quotes can escape themselves. Backslash quotes everything.
+ *
+ * Return the size of the name of the declaration or 0 if no header was found.
+ * As quantifiers may precede functions or predicates, we must list them too.
+ */
+
+static const char *Mercury_decl_tags[] = {"type", "solver type", "pred",
+ "func", "inst", "mode", "typeclass", "instance", "pragma", "promise",
+ "initialise", "finalise", "mutable", "module", "interface", "implementation",
+ "import_module", "use_module", "include_module", "end_module", "some", "all"};
+
+static size_t
+mercury_decl (char *s, size_t pos)
+{
+ if (s == NULL) return 0;
+
+ size_t origpos;
+ origpos = pos;
+
+ while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) ++pos;
+
+ unsigned char decl_type_length = pos - origpos;
+ char buf[decl_type_length + 1];
+ memset (buf, 0, decl_type_length + 1);
+
+ /* Mercury declaration tags. Consume them, then check the declaration item
+ following :- is legitimate, then go on as in the prolog case. */
+
+ memcpy (buf, &s[origpos], decl_type_length);
+
+ bool found_decl_tag = false;
+
+ if (is_mercury_quantifier)
+ {
+ if (strcmp (buf, "pred") != 0 && strcmp (buf, "func") != 0) /* Bad syntax. */
+ return 0;
+ is_mercury_quantifier = false; /* Beset to base value. */
+ found_decl_tag = true;
+ }
+ else
+ {
+ for (int j = 0; j < sizeof (Mercury_decl_tags) / sizeof (char*); ++j)
+ {
+ if (strcmp (buf, Mercury_decl_tags[j]) == 0)
+ {
+ found_decl_tag = true;
+ if (strcmp (buf, "type") == 0)
+ is_mercury_type = true;
+
+ if (strcmp (buf, "some") == 0
+ || strcmp (buf, "all") == 0)
+ {
+ is_mercury_quantifier = true;
+ }
+
+ break; /* Found declaration tag of rank j. */
+ }
+ else
+ /* 'solver type' has a blank in the middle,
+ so this is the hard case. */
+ if (strcmp (buf, "solver") == 0)
+ {
+ ++pos;
+ while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_'))
+ ++pos;
+
+ decl_type_length = pos - origpos;
+ char buf2[decl_type_length + 1];
+ memset (buf2, 0, decl_type_length + 1);
+ memcpy (buf2, &s[origpos], decl_type_length);
+
+ if (strcmp (buf2, "solver type") == 0)
+ {
+ found_decl_tag = false;
+ break; /* Found declaration tag of rank j. */
+ }
+ }
+ }
+ }
+
+ /* If with_mercury_definitions == false
+ * this is a Mercury syntax error, ignoring... */
+
+ if (with_mercury_definitions)
+ {
+ if (found_decl_tag)
+ pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */
+ else
+ /* Prolog-like behavior
+ * we have parsed the predicate once, yet inappropriately
+ * so restarting again the parsing step. */
+ pos = 0;
+ }
+ else
+ {
+ if (found_decl_tag)
+ pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */
+ else
+ return 0;
+ }
+
+ /* From now on it is the same as for Prolog except for module dots. */
+
+ if (c_islower (s[pos]) || s[pos] == '_' )
+ {
+ /* The name is unquoted.
+ Do not confuse module dots with end-of-declaration dots. */
+
+ while (c_isalnum (s[pos])
+ || s[pos] == '_'
+ || (s[pos] == '.' /* A module dot. */
+ && s + pos + 1 != NULL
+ && (c_isalnum (s[pos + 1]) || s[pos + 1] == '_')))
+ ++pos;
+
+ return pos - origpos;
+ }
+ else if (s[pos] == '\'')
+ {
+ ++pos;
+ for (;;)
+ {
+ if (s[pos] == '\'')
+ {
+ ++pos;
+ if (s[pos] != '\'')
+ break;
+ ++pos; /* A double quote. */
+ }
+ else if (s[pos] == '\0') /* Multiline quoted atoms are ignored. */
+ return 0;
+ else if (s[pos] == '\\')
+ {
+ if (s[pos+1] == '\0')
+ return 0;
+ pos += 2;
+ }
+ else
+ ++pos;
+ }
+ return pos - origpos;
+ }
+ else if (is_mercury_quantifier && s[pos] == '[') /* :- some [T] pred/func. */
+ {
+ for (++pos; s + pos != NULL && s[pos] != ']'; ++pos) {}
+ if (s + pos == NULL) return 0;
+ ++pos;
+ pos = skip_spaces (s + pos) - s;
+ return mercury_decl (s, pos) + pos - origpos;
+ }
+ else
+ return 0;
+}
+
+static ptrdiff_t
+mercury_pr (char *s, char *last, ptrdiff_t lastlen)
+{
+ size_t len0 = 0;
+ is_mercury_type = false;
+ is_mercury_quantifier = false;
+
+ if (is_mercury_declaration)
+ {
+ /* Skip len0 blanks only for declarations. */
+ len0 = skip_spaces (s + 2) - s;
+ }
+
+ size_t len = mercury_decl (s , len0);
+ if (len == 0) return 0;
+ len += len0;
+
+ if (( (s[len] == '.' /* This is a statement dot, not a module dot. */
+ || (s[len] == '(' && (len += 1))
+ || (s[len] == ':' /* Stopping in case of a rule. */
+ && s[len + 1] == '-'
+ && (len += 2)))
+ && (lastlen != len || memcmp (s, last, len) != 0)
+ )
+ /* Types are often declared on several lines so keeping just
+ the first line. */
+ || is_mercury_type)
+ {
+ make_tag (s, 0, true, s, len, lineno, linecharno);
+ return len;
+ }
+
+ return 0;
+}
+
\f
/*
* Support for Erlang
diff --git a/test/manual/etags/Makefile b/test/manual/etags/Makefile
index c1df703905..eae6918256 100644
--- a/test/manual/etags/Makefile
+++ b/test/manual/etags/Makefile
@@ -28,10 +28,11 @@ RBSRC=
SCMSRC=$(addprefix ./scm-src/,test.scm)
TEXSRC=$(addprefix ./tex-src/,testenv.tex gzip.texi texinfo.tex nonewline.tex)
YSRC=$(addprefix ./y-src/,parse.y parse.c atest.y cccp.c cccp.y)
+MERCSRC=$(addprefix ./merc-src/,array.m)
SRCS=${ADASRC} ${ASRC} ${CSRC} ${CPSRC} ${ELSRC} ${ERLSRC} ${FSRC}\
${FORTHSRC} ${GOSRC} ${HTMLSRC} ${JAVASRC} ${LUASRC} ${MAKESRC}\
${OBJCSRC} ${OBJCPPSRC} ${PASSRC} ${PHPSRC} ${PERLSRC} ${PSSRC}\
- ${PROLSRC} ${PYTSRC} ${RBSRC} ${SCMSRC} ${TEXSRC} ${YSRC}
+ ${PROLSRC} ${PYTSRC} ${RBSRC} ${SCMSRC} ${TEXSRC} ${YSRC} ${MERCSRC}
NONSRCS=./f-src/entry.strange ./erl-src/lists.erl ./cp-src/clheir.hpp.gz
ETAGS_PROG=../../../lib-src/etags
diff --git a/test/manual/etags/merc-src/array.m b/test/manual/etags/merc-src/array.m
new file mode 100644
index 0000000000..0663c41087
--- /dev/null
+++ b/test/manual/etags/merc-src/array.m
@@ -0,0 +1,3416 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+% Copyright (C) 1993-1995, 1997-2012 The University of Melbourne.
+% Copyright (C) 2013-2018 The Mercury team.
+% This file is distributed under the terms specified in COPYING.LIB.
+%---------------------------------------------------------------------------%
+%
+% File: array.m.
+% Main authors: fjh, bromage.
+% Stability: medium-low.
+%
+% This module provides dynamically-sized one-dimensional arrays.
+% Array indices start at zero.
+%
+% WARNING!
+%
+% Arrays are currently not unique objects. until this situation is resolved,
+% it is up to the programmer to ensure that arrays are used in ways that
+% preserve correctness. In the absence of mode reordering, one should therefore
+% assume that evaluation will take place in left-to-right order. For example,
+% the following code will probably not work as expected (f is a function,
+% A an array, I an index, and X an appropriate value):
+%
+% Y = f(A ^ elem(I) := X, A ^ elem(I))
+%
+% The compiler is likely to compile this as
+%
+% V0 = A ^ elem(I) := X,
+% V1 = A ^ elem(I),
+% Y = f(V0, V1)
+%
+% and will be unaware that the first line should be ordered *after* the second.
+% The safest thing to do is write things out by hand in the form
+%
+% A0I = A0 ^ elem(I),
+% A1 = A0 ^ elem(I) := X,
+% Y = f(A1, A0I)
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module array.
+:- interface.
+
+:- import_module list.
+:- import_module pretty_printer.
+:- import_module random.
+
+:- type array(T).
+
+:- inst array(I) == ground.
+:- inst array == array(ground).
+
+ % XXX the current Mercury compiler doesn't support `ui' modes,
+ % so to work-around that problem, we currently don't use
+ % unique modes in this module.
+
+% :- inst uniq_array(I) == unique.
+% :- inst uniq_array == uniq_array(unique).
+:- inst uniq_array(I) == array(I). % XXX work-around
+:- inst uniq_array == uniq_array(ground). % XXX work-around
+
+:- mode array_di == di(uniq_array).
+:- mode array_uo == out(uniq_array).
+:- mode array_ui == in(uniq_array).
+
+% :- inst mostly_uniq_array(I) == mostly_unique).
+% :- inst mostly_uniq_array == mostly_uniq_array(mostly_unique).
+:- inst mostly_uniq_array(I) == array(I). % XXX work-around
+:- inst mostly_uniq_array == mostly_uniq_array(ground). % XXX work-around
+
+:- mode array_mdi == mdi(mostly_uniq_array).
+:- mode array_muo == out(mostly_uniq_array).
+:- mode array_mui == in(mostly_uniq_array).
+
+ % An `index_out_of_bounds' is the exception thrown
+ % on out-of-bounds array accesses. The string describes
+ % the predicate or function reporting the error.
+:- type index_out_of_bounds
+ ---> index_out_of_bounds(string).
+
+%---------------------------------------------------------------------------%
+
+ % make_empty_array(Array) creates an array of size zero
+ % starting at lower bound 0.
+ %
+:- pred make_empty_array(array(T)::array_uo) is det.
+
+:- func make_empty_array = (array(T)::array_uo) is det.
+
+ % init(Size, Init, Array) creates an array with bounds from 0
+ % to Size-1, with each element initialized to Init. Throws an
+ % exception if Size < 0.
+ %
+:- pred init(int, T, array(T)).
+:- mode init(in, in, array_uo) is det.
+
+:- func init(int, T) = array(T).
+:- mode init(in, in) = array_uo is det.
+
+ % array/1 is a function that constructs an array from a list.
+ % (It does the same thing as the predicate from_list/2.)
+ % The syntax `array([...])' is used to represent arrays
+ % for io.read, io.write, term_to_type, and type_to_term.
+ %
+:- func array(list(T)) = array(T).
+:- mode array(in) = array_uo is det.
+
+ % generate(Size, Generate) = Array:
+ % Create an array with bounds from 0 to Size - 1 using the function
+ % Generate to set the initial value of each element of the array.
+ % The initial value of the element at index K will be the result of
+ % calling the function Generate(K). Throws an exception if Size < 0.
+ %
+:- func generate(int::in, (func(int) = T)::in) = (array(T)::array_uo)
+ is det.
+
+ % generate_foldl(Size, Generate, Array, !Acc):
+ % As above, but using a predicate with an accumulator threaded through it
+ % to generate the initial value of each element.
+ %
+:- pred generate_foldl(int, pred(int, T, A, A), array(T), A, A).
+:- mode generate_foldl(in, in(pred(in, out, in, out) is det),
+ array_uo, in, out) is det.
+:- mode generate_foldl(in, in(pred(in, out, mdi, muo) is det),
+ array_uo, mdi, muo) is det.
+:- mode generate_foldl(in, in(pred(in, out, di, uo) is det),
+ array_uo, di, uo) is det.
+:- mode generate_foldl(in, in(pred(in, out, in, out) is semidet),
+ array_uo, in, out) is semidet.
+:- mode generate_foldl(in, in(pred(in, out, mdi, muo) is semidet),
+ array_uo, mdi, muo) is semidet.
+:- mode generate_foldl(in, in(pred(in, out, di, uo) is semidet),
+ array_uo, di, uo) is semidet.
+
+%---------------------------------------------------------------------------%
+
+ % min returns the lower bound of the array.
+ % Note: in this implementation, the lower bound is always zero.
+ %
+:- pred min(array(_T), int).
+%:- mode min(array_ui, out) is det.
+:- mode min(in, out) is det.
+
+:- func min(array(_T)) = int.
+%:- mode min(array_ui) = out is det.
+:- mode min(in) = out is det.
+
+ % det_least_index returns the lower bound of the array.
+ % Throws an exception if the array is empty.
+ %
+:- func det_least_index(array(T)) = int.
+%:- mode det_least_index(array_ui) = out is det.
+:- mode det_least_index(in) = out is det.
+
+ % semidet_least_index returns the lower bound of the array,
+ % or fails if the array is empty.
+ %
+:- func semidet_least_index(array(T)) = int.
+%:- mode semidet_least_index(array_ui) = out is semidet.
+:- mode semidet_least_index(in) = out is semidet.
+
+ % max returns the upper bound of the array.
+ % Returns lower bound - 1 for an empty array
+ % (always -1 in this implementation).
+ %
+:- pred max(array(_T), int).
+%:- mode max(array_ui, out) is det.
+:- mode max(in, out) is det.
+
+:- func max(array(_T)) = int.
+%:- mode max(array_ui) = out is det.
+:- mode max(in) = out is det.
+
+ % det_greatest_index returns the upper bound of the array.
+ % Throws an exception if the array is empty.
+ %
+:- func det_greatest_index(array(T)) = int.
+%:- mode det_greatest_index(array_ui) = out is det.
+:- mode det_greatest_index(in) = out is det.
+
+ % semidet_greatest_index returns the upper bound of the array,
+ % or fails if the array is empty.
+ %
+:- func semidet_greatest_index(array(T)) = int.
+%:- mode semidet_greatest_index(array_ui) = out is semidet.
+:- mode semidet_greatest_index(in) = out is semidet.
+
+ % size returns the length of the array,
+ % i.e. upper bound - lower bound + 1.
+ %
+:- pred size(array(_T), int).
+%:- mode size(array_ui, out) is det.
+:- mode size(in, out) is det.
+
+:- func size(array(_T)) = int.
+%:- mode size(array_ui) = out is det.
+:- mode size(in) = out is det.
+
+ % bounds(Array, Min, Max) returns the lower and upper bounds of an array.
+ % The upper bound will be lower bound - 1 for an empty array.
+ % Note: in this implementation, the lower bound is always zero.
+ %
+:- pred bounds(array(_T), int, int).
+%:- mode bounds(array_ui, out, out) is det.
+:- mode bounds(in, out, out) is det.
+
+ % in_bounds checks whether an index is in the bounds of an array.
+ %
+:- pred in_bounds(array(_T), int).
+%:- mode in_bounds(array_ui, in) is semidet.
+:- mode in_bounds(in, in) is semidet.
+
+ % is_empty(Array):
+ % True iff Array is an array of size zero.
+ %
+:- pred is_empty(array(_T)).
+%:- mode is_empty(array_ui) is semidet.
+:- mode is_empty(in) is semidet.
+
+%---------------------------------------------------------------------------%
+
+ % lookup returns the N'th element of an array.
+ % Throws an exception if the index is out of bounds.
+ %
+:- pred lookup(array(T), int, T).
+%:- mode lookup(array_ui, in, out) is det.
+:- mode lookup(in, in, out) is det.
+
+:- func lookup(array(T), int) = T.
+%:- mode lookup(array_ui, in) = out is det.
+:- mode lookup(in, in) = out is det.
+
+ % semidet_lookup returns the N'th element of an array.
+ % It fails if the index is out of bounds.
+ %
+:- pred semidet_lookup(array(T), int, T).
+%:- mode semidet_lookup(array_ui, in, out) is semidet.
+:- mode semidet_lookup(in, in, out) is semidet.
+
+ % unsafe_lookup returns the N'th element of an array.
+ % It is an error if the index is out of bounds.
+ %
+:- pred unsafe_lookup(array(T), int, T).
+%:- mode unsafe_lookup(array_ui, in, out) is det.
+:- mode unsafe_lookup(in, in, out) is det.
+
+ % set sets the N'th element of an array, and returns the
+ % resulting array (good opportunity for destructive update ;-).
+ % Throws an exception if the index is out of bounds.
+ %
+:- pred set(int, T, array(T), array(T)).
+:- mode set(in, in, array_di, array_uo) is det.
+
+:- func set(array(T), int, T) = array(T).
+:- mode set(array_di, in, in) = array_uo is det.
+
+ % semidet_set sets the nth element of an array, and returns
+ % the resulting array. It fails if the index is out of bounds.
+ %
+:- pred semidet_set(int, T, array(T), array(T)).
+:- mode semidet_set(in, in, array_di, array_uo) is semidet.
+
+ % unsafe_set sets the nth element of an array, and returns the
+ % resulting array. It is an error if the index is out of bounds.
+ %
+:- pred unsafe_set(int, T, array(T), array(T)).
+:- mode unsafe_set(in, in, array_di, array_uo) is det.
+
+ % slow_set sets the nth element of an array, and returns the
+ % resulting array. The initial array is not required to be unique,
+ % so the implementation may not be able to use destructive update.
+ % It is an error if the index is out of bounds.
+ %
+:- pred slow_set(int, T, array(T), array(T)).
+%:- mode slow_set(in, in, array_ui, array_uo) is det.
+:- mode slow_set(in, in, in, array_uo) is det.
+
+:- func slow_set(array(T), int, T) = array(T).
+%:- mode slow_set(array_ui, in, in) = array_uo is det.
+:- mode slow_set(in, in, in) = array_uo is det.
+
+ % semidet_slow_set sets the nth element of an array, and returns
+ % the resulting array. The initial array is not required to be unique,
+ % so the implementation may not be able to use destructive update.
+ % It fails if the index is out of bounds.
+ %
+:- pred semidet_slow_set(int, T, array(T), array(T)).
+%:- mode semidet_slow_set(in, in, array_ui, array_uo) is semidet.
+:- mode semidet_slow_set(in, in, in, array_uo) is semidet.
+
+ % Field selection for arrays.
+ % Array ^ elem(Index) = lookup(Array, Index).
+ %
+:- func elem(int, array(T)) = T.
+%:- mode elem(in, array_ui) = out is det.
+:- mode elem(in, in) = out is det.
+
+ % As above, but omit the bounds check.
+ %
+:- func unsafe_elem(int, array(T)) = T.
+%:- mode unsafe_elem(in, array_ui) = out is det.
+:- mode unsafe_elem(in, in) = out is det.
+
+ % Field update for arrays.
+ % (Array ^ elem(Index) := Value) = set(Array, Index, Value).
+ %
+:- func 'elem :='(int, array(T), T) = array(T).
+:- mode 'elem :='(in, array_di, in) = array_uo is det.
+
+ % As above, but omit the bounds check.
+ %
+:- func 'unsafe_elem :='(int, array(T), T) = array(T).
+:- mode 'unsafe_elem :='(in, array_di, in) = array_uo is det.
+
+ % swap(I, J, !Array):
+ % Swap the item in the I'th position with the item in the J'th position.
+ % Throws an exception if either of I or J is out-of-bounds.
+ %
+:- pred swap(int, int, array(T), array(T)).
+:- mode swap(in, in, array_di, array_uo) is det.
+
+ % As above, but omit the bounds checks.
+ %
+:- pred unsafe_swap(int, int, array(T), array(T)).
+:- mode unsafe_swap(in, in, array_di, array_uo) is det.
+
+ % Returns every element of the array, one by one.
+ %
+:- pred member(array(T)::in, T::out) is nondet.
+
+%---------------------------------------------------------------------------%
+
+ % copy(Array0, Array):
+ % Makes a new unique copy of an array.
+ %
+:- pred copy(array(T), array(T)).
+%:- mode copy(array_ui, array_uo) is det.
+:- mode copy(in, array_uo) is det.
+
+:- func copy(array(T)) = array(T).
+%:- mode copy(array_ui) = array_uo is det.
+:- mode copy(in) = array_uo is det.
+
+ % resize(Size, Init, Array0, Array):
+ % The array is expanded or shrunk to make it fit the new size `Size'.
+ % Any new entries are filled with `Init'. Throws an exception if
+ % `Size' < 0.
+ %
+:- pred resize(int, T, array(T), array(T)).
+:- mode resize(in, in, array_di, array_uo) is det.
+
+ % resize(Array0, Size, Init) = Array:
+ % The array is expanded or shrunk to make it fit the new size `Size'.
+ % Any new entries are filled with `Init'. Throws an exception if
+ % `Size' < 0.
+ %
+:- func resize(array(T), int, T) = array(T).
+:- mode resize(array_di, in, in) = array_uo is det.
+
+ % shrink(Size, Array0, Array):
+ % The array is shrunk to make it fit the new size `Size'.
+ % Throws an exception if `Size' is larger than the size of `Array0' or
+ % if `Size' < 0.
+ %
+:- pred shrink(int, array(T), array(T)).
+:- mode shrink(in, array_di, array_uo) is det.
+
+ % shrink(Array0, Size) = Array:
+ % The array is shrunk to make it fit the new size `Size'.
+ % Throws an exception if `Size' is larger than the size of `Array0' or
+ % if `Size' < 0.
+ %
+:- func shrink(array(T), int) = array(T).
+:- mode shrink(array_di, in) = array_uo is det.
+
+ % fill(Item, Array0, Array):
+ % Sets every element of the array to `Elem'.
+ %
+:- pred fill(T::in, array(T)::array_di, array(T)::array_uo) is det.
+
+ % fill_range(Item, Lo, Hi, !Array):
+ % Sets every element of the array with index in the range Lo..Hi
+ % (inclusive) to Item. Throws a software_error/1 exception if Lo > Hi.
+ % Throws an index_out_of_bounds/0 exception if Lo or Hi is out of bounds.
+ %
+:- pred fill_range(T::in, int::in, int::in,
+ array(T)::array_di, array(T)::array_uo) is det.
+
+ % from_list takes a list, and returns an array containing those
+ % elements in the same order that they occurred in the list.
+ %
+:- func from_list(list(T)::in) = (array(T)::array_uo) is det.
+:- pred from_list(list(T)::in, array(T)::array_uo) is det.
+
+ % from_reverse_list takes a list, and returns an array containing
+ % those elements in the reverse order that they occurred in the list.
+ %
+:- func from_reverse_list(list(T)::in) = (array(T)::array_uo) is det.
+
+ % to_list takes an array and returns a list containing the elements
+ % of the array in the same order that they occurred in the array.
+ %
+:- pred to_list(array(T), list(T)).
+%:- mode to_list(array_ui, out) is det.
+:- mode to_list(in, out) is det.
+
+:- func to_list(array(T)) = list(T).
+%:- mode to_list(array_ui) = out is det.
+:- mode to_list(in) = out is det.
+
+ % fetch_items(Array, Lo, Hi, List):
+ % Returns a list containing the items in the array with index in the range
+ % Lo..Hi (both inclusive) in the same order that they occurred in the
+ % array. Returns an empty list if Hi < Lo. Throws an index_out_of_bounds/0
+ % exception if either Lo or Hi is out of bounds, *and* Hi >= Lo.
+ %
+ % If Hi < Lo, we do not generate an exception even if either or both
+ % are out of bounds, for two reasons. First, there is no need; if Hi < Lo,
+ % we can return the empty list without accessing any element of the array.
+ % Second, without this rule, some programming techniques for accessing
+ % consecutive contiguous regions of an array would require explicit
+ % bound checks in the *caller* of fetch_items, which would duplicate
+ % the checks inside fetch_items itself.
+ %
+:- pred fetch_items(array(T), int, int, list(T)).
+:- mode fetch_items(in, in, in, out) is det.
+
+:- func fetch_items(array(T), int, int) = list(T).
+%:- mode fetch_items(array_ui, in, in) = out is det.
+:- mode fetch_items(in, in, in) = out is det.
+
+ % binary_search(A, X, I) does a binary search for the element X
+ % in the array A. If there is an element with that value in the array,
+ % it returns its index I; otherwise, it fails.
+ %
+ % The array A must be sorted into ascending order with respect to the
+ % the builtin Mercury order on terms for binary_search/3, and with respect
+ % to supplied comparison predicate for binary_search/4.
+ %
+ % The array may contain duplicates. If it does, and a search looks for
+ % a duplicated value, the search will return the index of one of the
+ % copies, but it is not specified *which* copy's index it will return.
+ %
+:- pred binary_search(array(T)::array_ui,
+ T::in, int::out) is semidet.
+:- pred binary_search(comparison_func(T)::in, array(T)::array_ui,
+ T::in, int::out) is semidet.
+
+ % approx_binary_search(A, X, I) does a binary search for the element X
+ % in the array A. If there is an element with that value in the array,
+ % it returns its index I. If there is no element with that value in the
+ % array, it returns an index whose slot contains the highest value in the
+ % array that is less than X, as measured by the builtin Mercury order
+ % on terms for approx_binary_search/3, and as measured by the supplied
+ % ordering for approx_binary_search/4. It will fail only if there is
+ % no value smaller than X in the array.
+ %
+ % The array A must be sorted into ascending order with respect to the
+ % the builtin Mercury order on terms for approx_binary_search/3, and
+ % with respect to supplied comparison predicate for approx_binary_search/4.
+ %
+ % The array may contain duplicates. If it does, and if either the
+ % searched-for value or (if that does not exist) the highest value
+ % smaller than the searched-for value is duplicated, the search will return
+ % the index of one of the copies, but it is not specified *which* copy's
+ % index it will return.
+ %
+:- pred approx_binary_search(array(T)::array_ui,
+ T::in, int::out) is semidet.
+:- pred approx_binary_search(comparison_func(T)::in, array(T)::array_ui,
+ T::in, int::out) is semidet.
+
+ % map(Closure, OldArray, NewArray) applies `Closure' to
+ % each of the elements of `OldArray' to create `NewArray'.
+ %
+:- pred map(pred(T1, T2), array(T1), array(T2)).
+%:- mode map(pred(in, out) is det, array_ui, array_uo) is det.
+:- mode map(pred(in, out) is det, in, array_uo) is det.
+
+:- func map(func(T1) = T2, array(T1)) = array(T2).
+%:- mode map(func(in) = out is det, array_ui) = array_uo is det.
+:- mode map(func(in) = out is det, in) = array_uo is det.
+
+:- func array_compare(array(T), array(T)) = comparison_result.
+:- mode array_compare(in, in) = uo is det.
+
+ % sort(Array) returns a version of Array sorted into ascending
+ % order.
+ %
+ % This sort is not stable. That is, elements that compare/3 decides are
+ % equal will appear together in the sorted array, but not necessarily
+ % in the same order in which they occurred in the input array. This is
+ % primarily only an issue with types with user-defined equivalence for
+ % which `equivalent' objects are otherwise distinguishable.
+ %
+:- func sort(array(T)) = array(T).
+:- mode sort(array_di) = array_uo is det.
+
+ % array.sort was previously buggy. This symbol provides a way to ensure
+ % that you are using the fixed version.
+ %
+:- pred array.sort_fix_2014 is det.
+
+ % foldl(Fn, Array, X) is equivalent to
+ % list.foldl(Fn, to_list(Array), X)
+ % but more efficient.
+ %
+:- func foldl(func(T1, T2) = T2, array(T1), T2) = T2.
+%:- mode foldl(func(in, in) = out is det, array_ui, in) = out is det.
+:- mode foldl(func(in, in) = out is det, in, in) = out is det.
+%:- mode foldl(func(in, di) = uo is det, array_ui, di) = uo is det.
+:- mode foldl(func(in, di) = uo is det, in, di) = uo is det.
+
+ % foldl(Pr, Array, !X) is equivalent to
+ % list.foldl(Pr, to_list(Array), !X)
+ % but more efficient.
+ %
+:- pred foldl(pred(T1, T2, T2), array(T1), T2, T2).
+:- mode foldl(pred(in, in, out) is det, in, in, out) is det.
+:- mode foldl(pred(in, mdi, muo) is det, in, mdi, muo) is det.
+:- mode foldl(pred(in, di, uo) is det, in, di, uo) is det.
+:- mode foldl(pred(in, in, out) is semidet, in, in, out) is semidet.
+:- mode foldl(pred(in, mdi, muo) is semidet, in, mdi, muo) is semidet.
+:- mode foldl(pred(in, di, uo) is semidet, in, di, uo) is semidet.
+
+ % foldl2(Pr, Array, !X, !Y) is equivalent to
+ % list.foldl2(Pr, to_list(Array), !X, !Y)
+ % but more efficient.
+ %
+:- pred foldl2(pred(T1, T2, T2, T3, T3), array(T1), T2, T2, T3, T3).
+:- mode foldl2(pred(in, in, out, in, out) is det, in, in, out, in, out)
+ is det.
+:- mode foldl2(pred(in, in, out, mdi, muo) is det, in, in, out, mdi, muo)
+ is det.
+:- mode foldl2(pred(in, in, out, di, uo) is det, in, in, out, di, uo)
+ is det.
+:- mode foldl2(pred(in, in, out, in, out) is semidet, in,
+ in, out, in, out) is semidet.
+:- mode foldl2(pred(in, in, out, mdi, muo) is semidet, in,
+ in, out, mdi, muo) is semidet.
+:- mode foldl2(pred(in, in, out, di, uo) is semidet, in,
+ in, out, di, uo) is semidet.
+
+ % As above, but with three accumulators.
+ %
+:- pred foldl3(pred(T1, T2, T2, T3, T3, T4, T4), array(T1),
+ T2, T2, T3, T3, T4, T4).
+:- mode foldl3(pred(in, in, out, in, out, in, out) is det,
+ in, in, out, in, out, in, out) is det.
+:- mode foldl3(pred(in, in, out, in, out, mdi, muo) is det,
+ in, in, out, in, out, mdi, muo) is det.
+:- mode foldl3(pred(in, in, out, in, out, di, uo) is det,
+ in, in, out, in, out, di, uo) is det.
+:- mode foldl3(pred(in, in, out, in, out, in, out) is semidet,
+ in, in, out, in, out, in, out) is semidet.
+:- mode foldl3(pred(in, in, out, in, out, mdi, muo) is semidet,
+ in, in, out, in, out, mdi, muo) is semidet.
+:- mode foldl3(pred(in, in, out, in, out, di, uo) is semidet,
+ in, in, out, in, out, di, uo) is semidet.
+
+ % As above, but with four accumulators.
+ %
+:- pred foldl4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), array(T1),
+ T2, T2, T3, T3, T4, T4, T5, T5).
+:- mode foldl4(pred(in, in, out, in, out, in, out, in, out) is det,
+ in, in, out, in, out, in, out, in, out) is det.
+:- mode foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is det,
+ in, in, out, in, out, in, out, mdi, muo) is det.
+:- mode foldl4(pred(in, in, out, in, out, in, out, di, uo) is det,
+ in, in, out, in, out, in, out, di, uo) is det.
+:- mode foldl4(pred(in, in, out, in, out, in, out, in, out) is semidet,
+ in, in, out, in, out, in, out, in, out) is semidet.
+:- mode foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode foldl4(pred(in, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, out, in, out, in, out, di, uo) is semidet.
+
+ % As above, but with five accumulators.
+ %
+:- pred foldl5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6),
+ array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6).
+:- mode foldl5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is det,
+ in, in, out, in, out, in, out, in, out, in, out) is det.
+:- mode foldl5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det,
+ in, in, out, in, out, in, out, in, out, mdi, muo) is det.
+:- mode foldl5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is det,
+ in, in, out, in, out, in, out, in, out, di, uo) is det.
+:- mode foldl5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is semidet,
+ in, in, out, in, out, in, out, in, out, in, out) is semidet.
+:- mode foldl5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, out, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode foldl5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, out, in, out, in, out, in, out, di, uo) is semidet.
+
+%---------------------%
+
+ % foldr(Fn, Array, X) is equivalent to
+ % list.foldr(Fn, to_list(Array), X)
+ % but more efficient.
+ %
+:- func foldr(func(T1, T2) = T2, array(T1), T2) = T2.
+%:- mode foldr(func(in, in) = out is det, array_ui, in) = out is det.
+:- mode foldr(func(in, in) = out is det, in, in) = out is det.
+%:- mode foldr(func(in, di) = uo is det, array_ui, di) = uo is det.
+:- mode foldr(func(in, di) = uo is det, in, di) = uo is det.
+
+ % foldr(P, Array, !Acc) is equivalent to
+ % list.foldr(P, to_list(Array), !Acc)
+ % but more efficient.
+ %
+:- pred foldr(pred(T1, T2, T2), array(T1), T2, T2).
+:- mode foldr(pred(in, in, out) is det, in, in, out) is det.
+:- mode foldr(pred(in, mdi, muo) is det, in, mdi, muo) is det.
+:- mode foldr(pred(in, di, uo) is det, in, di, uo) is det.
+:- mode foldr(pred(in, in, out) is semidet, in, in, out) is semidet.
+:- mode foldr(pred(in, mdi, muo) is semidet, in, mdi, muo) is semidet.
+:- mode foldr(pred(in, di, uo) is semidet, in, di, uo) is semidet.
+
+ % As above, but with two accumulators.
+ %
+:- pred foldr2(pred(T1, T2, T2, T3, T3), array(T1), T2, T2, T3, T3).
+:- mode foldr2(pred(in, in, out, in, out) is det, in, in, out, in, out)
+ is det.
+:- mode foldr2(pred(in, in, out, mdi, muo) is det, in, in, out, mdi, muo)
+ is det.
+:- mode foldr2(pred(in, in, out, di, uo) is det, in, in, out, di, uo)
+ is det.
+:- mode foldr2(pred(in, in, out, in, out) is semidet, in,
+ in, out, in, out) is semidet.
+:- mode foldr2(pred(in, in, out, mdi, muo) is semidet, in,
+ in, out, mdi, muo) is semidet.
+:- mode foldr2(pred(in, in, out, di, uo) is semidet, in,
+ in, out, di, uo) is semidet.
+
+ % As above, but with three accumulators.
+ %
+:- pred foldr3(pred(T1, T2, T2, T3, T3, T4, T4), array(T1),
+ T2, T2, T3, T3, T4, T4).
+:- mode foldr3(pred(in, in, out, in, out, in, out) is det, in,
+ in, out, in, out, in, out) is det.
+:- mode foldr3(pred(in, in, out, in, out, mdi, muo) is det, in,
+ in, out, in, out, mdi, muo) is det.
+:- mode foldr3(pred(in, in, out, in, out, di, uo) is det, in,
+ in, out, in, out, di, uo) is det.
+:- mode foldr3(pred(in, in, out, in, out, in, out) is semidet, in,
+ in, out, in, out, in, out) is semidet.
+:- mode foldr3(pred(in, in, out, in, out, mdi, muo) is semidet, in,
+ in, out, in, out, mdi, muo) is semidet.
+:- mode foldr3(pred(in, in, out, in, out, di, uo) is semidet, in,
+ in, out, in, out, di, uo) is semidet.
+
+ % As above, but with four accumulators.
+ %
+:- pred foldr4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), array(T1),
+ T2, T2, T3, T3, T4, T4, T5, T5).
+:- mode foldr4(pred(in, in, out, in, out, in, out, in, out) is det,
+ in, in, out, in, out, in, out, in, out) is det.
+:- mode foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is det,
+ in, in, out, in, out, in, out, mdi, muo) is det.
+:- mode foldr4(pred(in, in, out, in, out, in, out, di, uo) is det,
+ in, in, out, in, out, in, out, di, uo) is det.
+:- mode foldr4(pred(in, in, out, in, out, in, out, in, out) is semidet,
+ in, in, out, in, out, in, out, in, out) is semidet.
+:- mode foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode foldr4(pred(in, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, out, in, out, in, out, di, uo) is semidet.
+
+ % As above, but with five accumulators.
+ %
+:- pred foldr5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6),
+ array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6).
+:- mode foldr5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is det,
+ in, in, out, in, out, in, out, in, out, in, out) is det.
+:- mode foldr5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det,
+ in, in, out, in, out, in, out, in, out, mdi, muo) is det.
+:- mode foldr5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is det,
+ in, in, out, in, out, in, out, in, out, di, uo) is det.
+:- mode foldr5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is semidet,
+ in, in, out, in, out, in, out, in, out, in, out) is semidet.
+:- mode foldr5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, out, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode foldr5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, out, in, out, in, out, in, out, di, uo) is semidet.
+
+%---------------------%
+
+ % foldl_corresponding(P, A, B, !Acc):
+ %
+ % Does the same job as foldl, but works on two arrays in parallel.
+ % Throws an exception if the array arguments differ in size.
+ %
+:- pred foldl_corresponding(pred(T1, T2, T3, T3), array(T1), array(T2),
+ T3, T3).
+:- mode foldl_corresponding(in(pred(in, in, in, out) is det), in, in,
+ in, out) is det.
+:- mode foldl_corresponding(in(pred(in, in, mdi, muo) is det), in, in,
+ mdi, muo) is det.
+:- mode foldl_corresponding(in(pred(in, in, di, uo) is det), in, in,
+ di, uo) is det.
+:- mode foldl_corresponding(in(pred(in, in, in, out) is semidet), in, in,
+ in, out) is semidet.
+:- mode foldl_corresponding(in(pred(in, in, mdi, muo) is semidet), in, in,
+ mdi, muo) is semidet.
+:- mode foldl_corresponding(in(pred(in, in, di, uo) is semidet), in, in,
+ di, uo) is semidet.
+
+ % As above, but with two accumulators.
+ %
+:- pred foldl2_corresponding(pred(T1, T2, T3, T3, T4, T4),
+ array(T1), array(T2), T3, T3, T4, T4).
+:- mode foldl2_corresponding(in(pred(in, in, in, out, in, out) is det),
+ in, in, in, out, in, out) is det.
+:- mode foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is det),
+ in, in, in, out, mdi, muo) is det.
+:- mode foldl2_corresponding(in(pred(in, in, in, out, di, uo) is det),
+ in, in, in, out, di, uo) is det.
+:- mode foldl2_corresponding(in(pred(in, in, in, out, in, out) is semidet),
+ in, in, in, out, in, out) is semidet.
+:- mode foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is semidet),
+ in, in, in, out, mdi, muo) is semidet.
+:- mode foldl2_corresponding(in(pred(in, in, in, out, di, uo) is semidet),
+ in, in, in, out, di, uo) is semidet.
+
+%---------------------%
+
+ % map_foldl(P, A, B, !Acc):
+ % Invoke P(Aelt, Belt, !Acc) on each element of the A array,
+ % and construct array B from the resulting values of Belt.
+ %
+:- pred map_foldl(pred(T1, T2, T3, T3), array(T1), array(T2), T3, T3).
+:- mode map_foldl(in(pred(in, out, in, out) is det),
+ in, array_uo, in, out) is det.
+:- mode map_foldl(in(pred(in, out, mdi, muo) is det),
+ in, array_uo, mdi, muo) is det.
+:- mode map_foldl(in(pred(in, out, di, uo) is det),
+ in, array_uo, di, uo) is det.
+:- mode map_foldl(in(pred(in, out, in, out) is semidet),
+ in, array_uo, in, out) is semidet.
+
+%---------------------%
+
+ % map_corresponding_foldl(P, A, B, C, !Acc):
+ %
+ % Given two arrays A and B, invoke P(Aelt, Belt, Celt, !Acc) on
+ % each corresponding pair of elements Aelt and Belt. Build up the array C
+ % from the result Celt values. Return C and the final value of the
+ % accumulator.
+ %
+ % Throws an exception if A and B differ in size.
+ %
+:- pred map_corresponding_foldl(pred(T1, T2, T3, T4, T4),
+ array(T1), array(T2), array(T3), T4, T4).
+:- mode map_corresponding_foldl(
+ in(pred(in, in, out, in, out) is det),
+ in, in, array_uo, in, out) is det.
+:- mode map_corresponding_foldl(
+ in(pred(in, in, out, mdi, muo) is det),
+ in, in, array_uo, mdi, muo) is det.
+:- mode map_corresponding_foldl(
+ in(pred(in, in, out, di, uo) is det),
+ in, in, array_uo, di, uo) is det.
+:- mode map_corresponding_foldl(
+ in(pred(in, in, out, in, out) is semidet),
+ in, in, array_uo, in, out) is semidet.
+:- mode map_corresponding_foldl(
+ in(pred(in, in, out, mdi, muo) is semidet),
+ in, in, array_uo, mdi, muo) is semidet.
+:- mode map_corresponding_foldl(
+ in(pred(in, in, out, di, uo) is semidet),
+ in, in, array_uo, di, uo) is semidet.
+
+%---------------------%
+
+ % all_true(Pred, Array):
+ % True iff Pred is true for every element of Array.
+ %
+:- pred all_true(pred(T), array(T)).
+%:- mode all_true(in(pred(in) is semidet), array_ui) is semidet.
+:- mode all_true(in(pred(in) is semidet), in) is semidet.
+
+ % all_false(Pred, Array):
+ % True iff Pred is false for every element of Array.
+ %
+:- pred all_false(pred(T), array(T)).
+%:- mode all_false(in(pred(in) is semidet), array_ui) is semidet.
+:- mode all_false(in(pred(in) is semidet), in) is semidet.
+
+ % append(A, B) = C:
+ %
+ % Make C a concatenation of the arrays A and B.
+ %
+:- func append(array(T)::in, array(T)::in) = (array(T)::array_uo) is det.
+
+ % random_permutation(A0, A, RS0, RS) permutes the elements in
+ % A0 given random seed RS0 and returns the permuted array in A
+ % and the next random seed in RS.
+ %
+:- pred random_permutation(array(T)::array_di, array(T)::array_uo,
+ random.supply::mdi, random.supply::muo) is det.
+
+ % Convert an array to a pretty_printer.doc for formatting.
+ %
+:- func array_to_doc(array(T)) = pretty_printer.doc.
+:- mode array_to_doc(array_ui) = out is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+% Everything beyond here is not intended as part of the public interface,
+% and will not appear in the Mercury Library Reference Manual.
+
+:- interface.
+
+ % dynamic_cast/2 won't work for arbitrary arrays since array/1 is
+ % not a ground type (that is, dynamic_cast/2 will work when the
+ % target type is e.g. array(int), but not when it is array(T)).
+ %
+:- some [T2] pred dynamic_cast_to_array(T1::in, array(T2)::out) is semidet.
+
+:- implementation.
+
+:- import_module exception.
+:- import_module int.
+:- import_module require.
+:- import_module string.
+:- import_module type_desc.
+
+%
+% Define the array type appropriately for the different targets.
+% Note that the definitions here should match what is output by
+% mlds_to_c.m, mlds_to_csharp.m, or mlds_to_java.m for mlds.mercury_array_type.
+%
+
+ % MR_ArrayPtr is defined in runtime/mercury_types.h.
+:- pragma foreign_type("C", array(T), "MR_ArrayPtr")
+ where equality is array.array_equal,
+ comparison is array.array_compare.
+
+:- pragma foreign_type("C#", array(T), "System.Array")
+ where equality is array.array_equal,
+ comparison is array.array_compare.
+
+ % We can't use `java.lang.Object []', since we want a generic type
+ % that is capable of holding any kind of array, including e.g. `int []'.
+ % Java doesn't have any equivalent of .NET's System.Array class,
+ % so we just use the universal base `java.lang.Object'.
+:- pragma foreign_type("Java", array(T), "/* Array */ java.lang.Object")
+ where equality is array.array_equal,
+ comparison is array.array_compare.
+
+ % unify/2 for arrays
+ %
+:- pred array_equal(array(T)::in, array(T)::in) is semidet.
+:- pragma terminates(array_equal/2).
+
+array_equal(Array1, Array2) :-
+ ( if
+ array.size(Array1, Size),
+ array.size(Array2, Size)
+ then
+ equal_elements(0, Size, Array1, Array2)
+ else
+ fail
+ ).
+
+:- pred equal_elements(int, int, array(T), array(T)).
+:- mode equal_elements(in, in, in, in) is semidet.
+
+equal_elements(N, Size, Array1, Array2) :-
+ ( if N = Size then
+ true
+ else
+ array.unsafe_lookup(Array1, N, Elem),
+ array.unsafe_lookup(Array2, N, Elem),
+ N1 = N + 1,
+ equal_elements(N1, Size, Array1, Array2)
+ ).
+
+array_compare(A1, A2) = C :-
+ array_compare(C, A1, A2).
+
+ % compare/3 for arrays
+ %
+:- pred array_compare(comparison_result::uo, array(T)::in, array(T)::in)
+ is det.
+:- pragma terminates(array_compare/3).
+
+array_compare(Result, Array1, Array2) :-
+ array.size(Array1, Size1),
+ array.size(Array2, Size2),
+ compare(SizeResult, Size1, Size2),
+ (
+ SizeResult = (=),
+ compare_elements(0, Size1, Array1, Array2, Result)
+ ;
+ ( SizeResult = (<)
+ ; SizeResult = (>)
+ ),
+ Result = SizeResult
+ ).
+
+:- pred compare_elements(int::in, int::in, array(T)::in, array(T)::in,
+ comparison_result::uo) is det.
+
+compare_elements(N, Size, Array1, Array2, Result) :-
+ ( if N = Size then
+ Result = (=)
+ else
+ array.unsafe_lookup(Array1, N, Elem1),
+ array.unsafe_lookup(Array2, N, Elem2),
+ compare(ElemResult, Elem1, Elem2),
+ (
+ ElemResult = (=),
+ N1 = N + 1,
+ compare_elements(N1, Size, Array1, Array2, Result)
+ ;
+ ( ElemResult = (<)
+ ; ElemResult = (>)
+ ),
+ Result = ElemResult
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred bounds_checks is semidet.
+:- pragma inline(bounds_checks/0).
+
+:- pragma foreign_proc("C",
+ bounds_checks,
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness, no_sharing],
+"
+#ifdef ML_OMIT_ARRAY_BOUNDS_CHECKS
+ SUCCESS_INDICATOR = MR_FALSE;
+#else
+ SUCCESS_INDICATOR = MR_TRUE;
+#endif
+").
+
+:- pragma foreign_proc("C#",
+ bounds_checks,
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+#if ML_OMIT_ARRAY_BOUNDS_CHECKS
+ SUCCESS_INDICATOR = false;
+#else
+ SUCCESS_INDICATOR = true;
+#endif
+").
+
+:- pragma foreign_proc("Java",
+ bounds_checks,
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ // never do bounds checking for Java (throw exceptions instead)
+ SUCCESS_INDICATOR = false;
+").
+
+%---------------------------------------------------------------------------%
+
+:- pragma foreign_decl("C", "
+#include ""mercury_heap.h"" // for MR_maybe_record_allocation()
+#include ""mercury_library_types.h"" // for MR_ArrayPtr
+
+// We do not yet record term sizes for arrays in term size profiling
+// grades. Doing so would require
+//
+// - modifying ML_alloc_array to allocate an extra word for the size;
+// - modifying all the predicates that call ML_alloc_array to compute the
+// size of the array (the sum of the sizes of the elements and the size of
+// the array itself);
+// - modifying all the predicates that update array elements to compute the
+// difference between the sizes of the terms being added to and deleted from
+// the array, and updating the array size accordingly.
+
+#define ML_alloc_array(newarray, arraysize, alloc_id) \
+ do { \
+ MR_Word newarray_word; \
+ MR_offset_incr_hp_msg(newarray_word, 0, (arraysize), \
+ alloc_id, ""array.array/1""); \
+ (newarray) = (MR_ArrayPtr) newarray_word; \
+ } while (0)
+").
+
+:- pragma foreign_decl("C", "
+void ML_init_array(MR_ArrayPtr, MR_Integer size, MR_Word item);
+").
+
+:- pragma foreign_code("C", "
+// The caller is responsible for allocating the memory for the array.
+// This routine does the job of initializing the already-allocated memory.
+void
+ML_init_array(MR_ArrayPtr array, MR_Integer size, MR_Word item)
+{
+ MR_Integer i;
+
+ array->size = size;
+ for (i = 0; i < size; i++) {
+ array->elements[i] = item;
+ }
+}
+").
+
+:- pragma foreign_code("C#", "
+
+public static System.Array
+ML_new_array(int Size, object Item)
+{
+ System.Array arr;
+ if (Size == 0) {
+ return null;
+ }
+ if (
+ Item is int || Item is uint || Item is sbyte || Item is byte ||
+ Item is short || Item is ushort || Item is long || Item is ulong ||
+ Item is double || Item is char || Item is bool
+ ) {
+ arr = System.Array.CreateInstance(Item.GetType(), Size);
+ } else {
+ arr = new object[Size];
+ }
+ for (int i = 0; i < Size; i++) {
+ arr.SetValue(Item, i);
+ }
+ return arr;
+}
+
+public static System.Array
+ML_unsafe_new_array(int Size, object Item, int IndexToSet)
+{
+ System.Array arr;
+
+ if (
+ Item is int || Item is uint || Item is sbyte || Item is byte ||
+ Item is short || Item is ushort || Item is long || Item is ulong ||
+ Item is double || Item is char || Item is bool
+ ) {
+ arr = System.Array.CreateInstance(Item.GetType(), Size);
+ } else {
+ arr = new object[Size];
+ }
+ arr.SetValue(Item, IndexToSet);
+ return arr;
+}
+
+public static System.Array
+ML_array_resize(System.Array arr0, int Size, object Item)
+{
+ if (Size == 0) {
+ return null;
+ }
+ if (arr0 == null) {
+ return ML_new_array(Size, Item);
+ }
+ if (arr0.Length == Size) {
+ return arr0;
+ }
+
+ int OldSize = arr0.Length;
+ System.Array arr;
+ if (Item is int) {
+ int[] tmp = (int[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is uint) {
+ uint[] tmp = (uint[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is sbyte) {
+ sbyte[] tmp = (sbyte[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is byte) {
+ byte[] tmp = (byte[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is short) {
+ short[] tmp = (short[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is ushort) {
+ ushort[] tmp = (ushort[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is long) {
+ long[] tmp = (long[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is ulong) {
+ ulong[] tmp = (ulong[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is double) {
+ double[] tmp = (double[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is char) {
+ char[] tmp = (char[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else if (Item is bool) {
+ bool[] tmp = (bool[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ } else {
+ object[] tmp = (object[]) arr0;
+ System.Array.Resize(ref tmp, Size);
+ arr = tmp;
+ }
+ for (int i = OldSize; i < Size; i++) {
+ arr.SetValue(Item, i);
+ }
+ return arr;
+}
+
+public static System.Array
+ML_shrink_array(System.Array arr, int Size)
+{
+ if (arr == null) {
+ return null;
+ }
+
+ // We need to use Item here to determine the type instead of arr itself
+ // since both 'arr is int[]' and 'arr is uint[]' evaluate to true;
+ // similarly for the other integer types. (That behaviour is due to an
+ // inconsistency between the covariance of value-typed arrays in C# and
+ // the CLR.)
+ object Item = arr.GetValue(0);
+ if (Item is int) {
+ int[] tmp = (int[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is uint) {
+ uint[] tmp = (uint[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is sbyte) {
+ sbyte[] tmp = (sbyte[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is byte) {
+ byte[] tmp = (byte[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is short) {
+ short[] tmp = (short[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is ushort) {
+ ushort[] tmp = (ushort[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is long) {
+ long[] tmp = (long[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is ulong) {
+ ulong[] tmp = (ulong[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is double) {
+ double[] tmp = (double[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is char) {
+ char[] tmp = (char[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else if (Item is bool) {
+ bool[] tmp = (bool[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ } else {
+ object[] tmp = (object[]) arr;
+ System.Array.Resize(ref tmp, Size);
+ return tmp;
+ }
+}
+").
+
+:- pragma foreign_code("Java", "
+public static Object
+ML_new_array(int Size, Object Item, boolean fill)
+{
+ if (Size == 0) {
+ return null;
+ }
+ if (Item instanceof Integer) {
+ int[] as = new int[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Integer) Item);
+ }
+ return as;
+ }
+ if (Item instanceof Double) {
+ double[] as = new double[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Double) Item);
+ }
+ return as;
+ }
+ if (Item instanceof Character) {
+ char[] as = new char[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Character) Item);
+ }
+ return as;
+ }
+ if (Item instanceof Boolean) {
+ boolean[] as = new boolean[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Boolean) Item);
+ }
+ return as;
+ }
+ if (Item instanceof Byte) {
+ byte[] as = new byte[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Byte) Item);
+ }
+ return as;
+ }
+ if (Item instanceof Short) {
+ short[] as = new short[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Short) Item);
+ }
+ return as;
+ }
+ if (Item instanceof Long) {
+ long[] as = new long[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Long) Item);
+ }
+ return as;
+ }
+ if (Item instanceof Float) {
+ float[] as = new float[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, (Float) Item);
+ }
+ return as;
+ }
+ Object[] as = new Object[Size];
+ if (fill) {
+ java.util.Arrays.fill(as, Item);
+ }
+ return as;
+}
+
+public static Object
+ML_unsafe_new_array(int Size, Object Item, int IndexToSet)
+{
+ if (Item instanceof Integer) {
+ int[] as = new int[Size];
+ as[IndexToSet] = (Integer) Item;
+ return as;
+ }
+ if (Item instanceof Double) {
+ double[] as = new double[Size];
+ as[IndexToSet] = (Double) Item;
+ return as;
+ }
+ if (Item instanceof Character) {
+ char[] as = new char[Size];
+ as[IndexToSet] = (Character) Item;
+ return as;
+ }
+ if (Item instanceof Boolean) {
+ boolean[] as = new boolean[Size];
+ as[IndexToSet] = (Boolean) Item;
+ return as;
+ }
+ if (Item instanceof Byte) {
+ byte[] as = new byte[Size];
+ as[IndexToSet] = (Byte) Item;
+ return as;
+ }
+ if (Item instanceof Short) {
+ short[] as = new short[Size];
+ as[IndexToSet] = (Short) Item;
+ return as;
+ }
+ if (Item instanceof Long) {
+ long[] as = new long[Size];
+ as[IndexToSet] = (Long) Item;
+ return as;
+ }
+ if (Item instanceof Float) {
+ float[] as = new float[Size];
+ as[IndexToSet] = (Float) Item;
+ return as;
+ }
+ Object[] as = new Object[Size];
+ as[IndexToSet] = Item;
+ return as;
+}
+
+public static int
+ML_array_size(Object Array)
+{
+ if (Array == null) {
+ return 0;
+ } else if (Array instanceof int[]) {
+ return ((int[]) Array).length;
+ } else if (Array instanceof double[]) {
+ return ((double[]) Array).length;
+ } else if (Array instanceof char[]) {
+ return ((char[]) Array).length;
+ } else if (Array instanceof boolean[]) {
+ return ((boolean[]) Array).length;
+ } else if (Array instanceof byte[]) {
+ return ((byte[]) Array).length;
+ } else if (Array instanceof short[]) {
+ return ((short[]) Array).length;
+ } else if (Array instanceof long[]) {
+ return ((long[]) Array).length;
+ } else if (Array instanceof float[]) {
+ return ((float[]) Array).length;
+ } else {
+ return ((Object[]) Array).length;
+ }
+}
+
+public static Object
+ML_array_resize(Object Array0, int Size, Object Item)
+{
+ if (Size == 0) {
+ return null;
+ }
+ if (Array0 == null) {
+ return ML_new_array(Size, Item, true);
+ }
+ if (ML_array_size(Array0) == Size) {
+ return Array0;
+ }
+ if (Array0 instanceof int[]) {
+ int[] arr0 = (int[]) Array0;
+ int[] Array = new int[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Integer) Item;
+ }
+ return Array;
+ }
+ if (Array0 instanceof double[]) {
+ double[] arr0 = (double[]) Array0;
+ double[] Array = new double[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Double) Item;
+ }
+ return Array;
+ }
+ if (Array0 instanceof char[]) {
+ char[] arr0 = (char[]) Array0;
+ char[] Array = new char[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Character) Item;
+ }
+ return Array;
+ }
+ if (Array0 instanceof boolean[]) {
+ boolean[] arr0 = (boolean[]) Array0;
+ boolean[] Array = new boolean[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Boolean) Item;
+ }
+ return Array;
+ }
+ if (Array0 instanceof byte[]) {
+ byte[] arr0 = (byte[]) Array0;
+ byte[] Array = new byte[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Byte) Item;
+ }
+ return Array;
+ }
+ if (Array0 instanceof short[]) {
+ short[] arr0 = (short[]) Array0;
+ short[] Array = new short[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Short) Item;
+ }
+ return Array;
+ }
+ if (Array0 instanceof long[]) {
+ long[] arr0 = (long[]) Array0;
+ long[] Array = new long[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Long) Item;
+ }
+ return Array;
+ }
+ if (Array0 instanceof float[]) {
+ float[] arr0 = (float[]) Array0;
+ float[] Array = new float[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = (Float) Item;
+ }
+ return Array;
+ } else {
+ Object[] arr0 = (Object[]) Array0;
+ Object[] Array = new Object[Size];
+
+ System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size));
+ for (int i = arr0.length; i < Size; i++) {
+ Array[i] = Item;
+ }
+ return Array;
+ }
+}
+
+public static Object
+ML_array_fill(Object array, int fromIndex, int toIndex, Object Item)
+{
+ if (array == null) {
+ return null;
+ }
+
+ if (array instanceof int[]) {
+ java.util.Arrays.fill(((int []) array), fromIndex, toIndex,
+ (Integer) Item);
+ } else if (array instanceof double[]) {
+ java.util.Arrays.fill(((double []) array), fromIndex, toIndex,
+ (Double) Item);
+ } else if (array instanceof byte[]) {
+ java.util.Arrays.fill(((byte []) array), fromIndex, toIndex,
+ (Byte) Item);
+ } else if (array instanceof short[]) {
+ java.util.Arrays.fill(((short []) array), fromIndex, toIndex,
+ (Short) Item);
+ } else if (array instanceof long[]) {
+ java.util.Arrays.fill(((long []) array), fromIndex, toIndex,
+ (Long) Item);
+ } else if (array instanceof char[]) {
+ java.util.Arrays.fill(((char []) array), fromIndex, toIndex,
+ (Character) Item);
+ } else if (array instanceof boolean[]) {
+ java.util.Arrays.fill(((boolean []) array), fromIndex, toIndex,
+ (Boolean) Item);
+ } else if (array instanceof float[]) {
+ java.util.Arrays.fill(((float []) array), fromIndex, toIndex,
+ (Float) Item);
+ } else {
+ java.util.Arrays.fill(((Object []) array), fromIndex, toIndex, Item);
+ }
+ return array;
+}
+").
+
+init(N, X) = A :-
+ array.init(N, X, A).
+
+init(Size, Item, Array) :-
+ ( if Size < 0 then
+ unexpected($pred, "negative size")
+ else
+ array.init_2(Size, Item, Array)
+ ).
+
+:- pred init_2(int::in, T::in, array(T)::array_uo) is det.
+
+:- pragma foreign_proc("C",
+ init_2(Size::in, Item::in, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness,
+ sharing(yes(int, T, array(T)), [
+ cel(Item, []) - cel(Array, [T])
+ ])
+ ],
+"
+ ML_alloc_array(Array, Size + 1, MR_ALLOC_ID);
+ ML_init_array(Array, Size, Item);
+").
+:- pragma foreign_proc("C#",
+ init_2(Size::in, Item::in, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Array = array.ML_new_array(Size, Item);
+").
+:- pragma foreign_proc("Java",
+ init_2(Size::in, Item::in, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Array = array.ML_new_array(Size, Item, true);
+").
+
+make_empty_array = A :-
+ array.make_empty_array(A).
+
+:- pragma foreign_proc("C",
+ make_empty_array(Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness, no_sharing],
+"
+ ML_alloc_array(Array, 1, MR_ALLOC_ID);
+ ML_init_array(Array, 0, 0);
+").
+:- pragma foreign_proc("C#",
+ make_empty_array(Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ // XXX A better solution than using the null pointer to represent
+ // the empty array would be to create an array of size 0. However,
+ // we need to determine the element type of the array before we can
+ // do that. This could be done by examining the RTTI of the array
+ // type and then using System.Type.GetType(""<mercury type>"") to
+ // determine it. However constructing the <mercury type> string is
+ // a non-trivial amount of work.
+ Array = null;
+").
+:- pragma foreign_proc("Java",
+ make_empty_array(Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ // XXX as per C#
+ Array = null;
+").
+
+%---------------------------------------------------------------------------%
+
+generate(Size, GenFunc) = Array :-
+ compare(Result, Size, 0),
+ (
+ Result = (<),
+ unexpected($pred, "negative size")
+ ;
+ Result = (=),
+ make_empty_array(Array)
+ ;
+ Result = (>),
+ FirstElem = GenFunc(0),
+ Array0 = unsafe_init(Size, FirstElem, 0),
+ Array = generate_2(1, Size, GenFunc, Array0)
+ ).
+
+:- func unsafe_init(int::in, T::in, int::in) = (array(T)::array_uo) is det.
+:- pragma foreign_proc("C",
+ unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo),
+ [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness],
+"
+ ML_alloc_array(Array, Size + 1, MR_ALLOC_ID);
+
+ // In debugging grades, we fill the array with the first element,
+ // in case the return value of a call to this predicate is examined
+ // in the debugger.
+ #if defined(MR_EXEC_TRACE)
+ ML_init_array(Array, Size, FirstElem);
+ #else
+ Array->size = Size;
+ Array->elements[IndexToSet] = FirstElem;
+ #endif
+
+").
+:- pragma foreign_proc("C#",
+ unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ Array = array.ML_unsafe_new_array(Size, FirstElem, IndexToSet);
+").
+:- pragma foreign_proc("Java",
+ unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ Array = array.ML_unsafe_new_array(Size, FirstElem, IndexToSet);
+").
+
+:- func generate_2(int::in, int::in, (func(int) = T)::in, array(T)::array_di)
+ = (array(T)::array_uo) is det.
+
+generate_2(Index, Size, GenFunc, !.Array) = !:Array :-
+ ( if Index < Size then
+ Elem = GenFunc(Index),
+ array.unsafe_set(Index, Elem, !Array),
+ !:Array = generate_2(Index + 1, Size, GenFunc, !.Array)
+ else
+ true
+ ).
+
+generate_foldl(Size, GenPred, Array, !Acc) :-
+ compare(Result, Size, 0),
+ (
+ Result = (<),
+ unexpected($pred, "negative size")
+ ;
+ Result = (=),
+ make_empty_array(Array)
+ ;
+ Result = (>),
+ GenPred(0, FirstElem, !Acc),
+ Array0 = unsafe_init(Size, FirstElem, 0),
+ generate_foldl_2(1, Size, GenPred, Array0, Array, !Acc)
+ ).
+
+:- pred generate_foldl_2(int, int, pred(int, T, A, A),
+ array(T), array(T), A, A).
+:- mode generate_foldl_2(in, in, in(pred(in, out, in, out) is det),
+ array_di, array_uo, in, out) is det.
+:- mode generate_foldl_2(in, in, in(pred(in, out, mdi, muo) is det),
+ array_di, array_uo, mdi, muo) is det.
+:- mode generate_foldl_2(in, in, in(pred(in, out, di, uo) is det),
+ array_di, array_uo, di, uo) is det.
+:- mode generate_foldl_2(in, in, in(pred(in, out, in, out) is semidet),
+ array_di, array_uo, in, out) is semidet.
+:- mode generate_foldl_2(in, in, in(pred(in, out, mdi, muo) is semidet),
+ array_di, array_uo, mdi, muo) is semidet.
+:- mode generate_foldl_2(in, in, in(pred(in, out, di, uo) is semidet),
+ array_di, array_uo, di, uo) is semidet.
+
+generate_foldl_2(Index, Size, GenPred, !Array, !Acc) :-
+ ( if Index < Size then
+ GenPred(Index, Elem, !Acc),
+ array.unsafe_set(Index, Elem, !Array),
+ generate_foldl_2(Index + 1, Size, GenPred, !Array, !Acc)
+ else
+ true
+ ).
+
+%---------------------------------------------------------------------------%
+
+min(A) = N :-
+ array.min(A, N).
+
+:- pragma foreign_proc("C",
+ min(Array::in, Min::out),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness, no_sharing],
+"
+ // Array not used.
+ Min = 0;
+").
+
+:- pragma foreign_proc("C#",
+ min(_Array::in, Min::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ // Array not used.
+ Min = 0;
+").
+
+
+:- pragma foreign_proc("Java",
+ min(_Array::in, Min::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ // Array not used.
+ Min = 0;
+").
+
+max(A) = N :-
+ array.max(A, N).
+
+:- pragma foreign_proc("C",
+ max(Array::in, Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness, no_sharing],
+"
+ Max = Array->size - 1;
+").
+:- pragma foreign_proc("C#",
+ max(Array::in, Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ if (Array != null) {
+ Max = Array.Length - 1;
+ } else {
+ Max = -1;
+ }
+").
+
+:- pragma foreign_proc("Java",
+ max(Array::in, Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ if (Array != null) {
+ Max = array.ML_array_size(Array) - 1;
+ } else {
+ Max = -1;
+ }
+").
+
+bounds(Array, Min, Max) :-
+ array.min(Array, Min),
+ array.max(Array, Max).
+
+%---------------------------------------------------------------------------%
+
+size(A) = N :-
+ array.size(A, N).
+
+:- pragma foreign_proc("C",
+ size(Array::in, Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness, no_sharing],
+"
+ Max = Array->size;
+").
+
+:- pragma foreign_proc("C#",
+ size(Array::in, Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ if (Array != null) {
+ Max = Array.Length;
+ } else {
+ Max = 0;
+ }
+").
+
+:- pragma foreign_proc("Java",
+ size(Array::in, Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Max = jmercury.array.ML_array_size(Array);
+").
+
+%---------------------------------------------------------------------------%
+
+in_bounds(Array, Index) :-
+ array.bounds(Array, Min, Max),
+ Min =< Index, Index =< Max.
+
+is_empty(Array) :-
+ array.size(Array, 0).
+
+semidet_set(Index, Item, !Array) :-
+ ( if array.in_bounds(!.Array, Index) then
+ array.unsafe_set(Index, Item, !Array)
+ else
+ fail
+ ).
+
+semidet_slow_set(Index, Item, !Array) :-
+ ( if array.in_bounds(!.Array, Index) then
+ array.slow_set(Index, Item, !Array)
+ else
+ fail
+ ).
+
+slow_set(!.Array, N, X) = !:Array :-
+ array.slow_set(N, X, !Array).
+
+slow_set(Index, Item, !Array) :-
+ array.copy(!Array),
+ array.set(Index, Item, !Array).
+
+%---------------------------------------------------------------------------%
+
+elem(Index, Array) = array.lookup(Array, Index).
+
+unsafe_elem(Index, Array) = Elem :-
+ array.unsafe_lookup(Array, Index, Elem).
+
+lookup(Array, N) = X :-
+ array.lookup(Array, N, X).
+
+lookup(Array, Index, Item) :-
+ ( if
+ bounds_checks,
+ not array.in_bounds(Array, Index)
+ then
+ out_of_bounds_error(Array, Index, "array.lookup")
+ else
+ array.unsafe_lookup(Array, Index, Item)
+ ).
+
+semidet_lookup(Array, Index, Item) :-
+ ( if array.in_bounds(Array, Index) then
+ array.unsafe_lookup(Array, Index, Item)
+ else
+ fail
+ ).
+
+:- pragma foreign_proc("C",
+ unsafe_lookup(Array::in, Index::in, Item::out),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness,
+ sharing(yes(array(T), int, T), [
+ cel(Array, [T]) - cel(Item, [])
+ ])
+ ],
+"
+ Item = Array->elements[Index];
+").
+
+:- pragma foreign_proc("C#",
+ unsafe_lookup(Array::in, Index::in, Item::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"{
+ Item = Array.GetValue(Index);
+}").
+
+:- pragma foreign_proc("Java",
+ unsafe_lookup(Array::in, Index::in, Item::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ if (Array instanceof int[]) {
+ Item = ((int[]) Array)[Index];
+ } else if (Array instanceof double[]) {
+ Item = ((double[]) Array)[Index];
+ } else if (Array instanceof char[]) {
+ Item = ((char[]) Array)[Index];
+ } else if (Array instanceof boolean[]) {
+ Item = ((boolean[]) Array)[Index];
+ } else if (Array instanceof byte[]) {
+ Item = ((byte[]) Array)[Index];
+ } else if (Array instanceof short[]) {
+ Item = ((short[]) Array)[Index];
+ } else if (Array instanceof long[]) {
+ Item = ((long[]) Array)[Index];
+ } else if (Array instanceof float[]) {
+ Item = ((float[]) Array)[Index];
+ } else {
+ Item = ((Object[]) Array)[Index];
+ }
+").
+
+%---------------------------------------------------------------------------%
+
+'elem :='(Index, Array, Value) = array.set(Array, Index, Value).
+
+set(A1, N, X) = A2 :-
+ array.set(N, X, A1, A2).
+
+set(Index, Item, !Array) :-
+ ( if
+ bounds_checks,
+ not array.in_bounds(!.Array, Index)
+ then
+ out_of_bounds_error(!.Array, Index, "array.set")
+ else
+ array.unsafe_set(Index, Item, !Array)
+ ).
+
+'unsafe_elem :='(Index, !.Array, Value) = !:Array :-
+ array.unsafe_set(Index, Value, !Array).
+
+:- pragma foreign_proc("C",
+ unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness,
+ sharing(yes(int, T, array(T), array(T)), [
+ cel(Array0, []) - cel(Array, []),
+ cel(Item, []) - cel(Array, [T])
+ ])
+ ],
+"
+ Array0->elements[Index] = Item; // destructive update!
+ Array = Array0;
+").
+
+:- pragma foreign_proc("C#",
+ unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"{
+ Array0.SetValue(Item, Index); // destructive update!
+ Array = Array0;
+}").
+
+:- pragma foreign_proc("Java",
+ unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ if (Array0 instanceof int[]) {
+ ((int[]) Array0)[Index] = (Integer) Item;
+ } else if (Array0 instanceof double[]) {
+ ((double[]) Array0)[Index] = (Double) Item;
+ } else if (Array0 instanceof char[]) {
+ ((char[]) Array0)[Index] = (Character) Item;
+ } else if (Array0 instanceof boolean[]) {
+ ((boolean[]) Array0)[Index] = (Boolean) Item;
+ } else if (Array0 instanceof byte[]) {
+ ((byte[]) Array0)[Index] = (Byte) Item;
+ } else if (Array0 instanceof short[]) {
+ ((short[]) Array0)[Index] = (Short) Item;
+ } else if (Array0 instanceof long[]) {
+ ((long[]) Array0)[Index] = (Long) Item;
+ } else if (Array0 instanceof float[]) {
+ ((float[]) Array0)[Index] = (Float) Item;
+ } else {
+ ((Object[]) Array0)[Index] = Item;
+ }
+ Array = Array0; // destructive update!
+").
+
+%---------------------------------------------------------------------------%
+
+% lower bounds other than zero are not supported
+% % array.resize takes an array and new lower and upper bounds.
+% % the array is expanded or shrunk at each end to make it fit
+% % the new bounds.
+% :- pred array.resize(array(T), int, int, array(T)).
+% :- mode array.resize(in, in, in, out) is det.
+
+:- pragma foreign_decl("C", "
+extern void
+ML_resize_array(MR_ArrayPtr new_array, MR_ArrayPtr old_array,
+ MR_Integer array_size, MR_Word item);
+").
+
+:- pragma foreign_code("C", "
+// The caller is responsible for allocating the storage for the new array.
+// This routine does the job of copying the old array elements to the
+// new array, initializing any additional elements in the new array,
+// and deallocating the old array.
+void
+ML_resize_array(MR_ArrayPtr array, MR_ArrayPtr old_array,
+ MR_Integer array_size, MR_Word item)
+{
+ MR_Integer i;
+ MR_Integer elements_to_copy;
+
+ elements_to_copy = old_array->size;
+ if (elements_to_copy > array_size) {
+ elements_to_copy = array_size;
+ }
+
+ array->size = array_size;
+ for (i = 0; i < elements_to_copy; i++) {
+ array->elements[i] = old_array->elements[i];
+ }
+ for (; i < array_size; i++) {
+ array->elements[i] = item;
+ }
+
+ // Since the mode on the old array is `array_di', it is safe to
+ // deallocate the storage for it.
+#ifdef MR_CONSERVATIVE_GC
+ MR_GC_free_attrib(old_array);
+#endif
+}
+").
+
+resize(!.Array, N, X) = !:Array :-
+ array.resize(N, X, !Array).
+
+resize(N, X, !Array) :-
+ ( if N < 0 then
+ unexpected($pred, "cannot resize to a negative size")
+ else
+ do_resize(N, X, !Array)
+ ).
+
+:- pred do_resize(int, T, array(T), array(T)).
+:- mode do_resize(in, in, array_di, array_uo) is det.
+
+:- pragma foreign_proc("C",
+ do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness,
+ sharing(yes(int, T, array(T), array(T)), [
+ cel(Array0, []) - cel(Array, []),
+ cel(Item, []) - cel(Array, [T])
+ ])
+ ],
+"
+ if ((Array0)->size == Size) {
+ Array = Array0;
+ } else {
+ ML_alloc_array(Array, Size + 1, MR_ALLOC_ID);
+ ML_resize_array(Array, Array0, Size, Item);
+ }
+").
+
+:- pragma foreign_proc("C#",
+ do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Array = array.ML_array_resize(Array0, Size, Item);
+").
+
+:- pragma foreign_proc("Java",
+ do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Array = jmercury.array.ML_array_resize(Array0, Size, Item);
+").
+
+%---------------------------------------------------------------------------%
+
+:- pragma foreign_decl("C", "
+extern void
+ML_shrink_array(MR_ArrayPtr array, MR_ArrayPtr old_array,
+ MR_Integer array_size);
+").
+
+:- pragma foreign_code("C", "
+// The caller is responsible for allocating the storage for the new array.
+// This routine does the job of copying the old array elements to the
+// new array and deallocating the old array.
+void
+ML_shrink_array(MR_ArrayPtr array, MR_ArrayPtr old_array,
+ MR_Integer array_size)
+{
+ MR_Integer i;
+
+ array->size = array_size;
+ for (i = 0; i < array_size; i++) {
+ array->elements[i] = old_array->elements[i];
+ }
+
+ // Since the mode on the old array is `array_di', it is safe to
+ // deallocate the storage for it.
+#ifdef MR_CONSERVATIVE_GC
+ MR_GC_free_attrib(old_array);
+#endif
+}
+").
+
+shrink(!.Array, N) = !:Array :-
+ array.shrink(N, !Array).
+
+shrink(Size, !Array) :-
+ OldSize = array.size(!.Array),
+ ( if Size < 0 then
+ unexpected($pred, "cannot shrink to a negative size")
+ else if Size > OldSize then
+ unexpected($pred, "cannot shrink to a larger size")
+ else if Size = OldSize then
+ true
+ else
+ array.shrink_2(Size, !Array)
+ ).
+
+:- pred shrink_2(int::in, array(T)::array_di, array(T)::array_uo) is det.
+
+:- pragma foreign_proc("C",
+ shrink_2(Size::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness,
+ sharing(yes(int, array(T), array(T)), [
+ cel(Array0, []) - cel(Array, [])
+ ])
+ ],
+"
+ ML_alloc_array(Array, Size + 1, MR_ALLOC_ID);
+ ML_shrink_array(Array, Array0, Size);
+").
+
+:- pragma foreign_proc("C#",
+ shrink_2(Size::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Array = array.ML_shrink_array(Array0, Size);
+").
+
+:- pragma foreign_proc("Java",
+ shrink_2(Size::in, Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ if (Array0 == null) {
+ Array = null;
+ } else if (Array0 instanceof int[]) {
+ Array = new int[Size];
+ } else if (Array0 instanceof double[]) {
+ Array = new double[Size];
+ } else if (Array0 instanceof byte[]) {
+ Array = new byte[Size];
+ } else if (Array0 instanceof short[]) {
+ Array = new short[Size];
+ } else if (Array0 instanceof long[]) {
+ Array = new long[Size];
+ } else if (Array0 instanceof char[]) {
+ Array = new char[Size];
+ } else if (Array0 instanceof float[]) {
+ Array = new float[Size];
+ } else if (Array0 instanceof boolean[]) {
+ Array = new boolean[Size];
+ } else {
+ Array = new Object[Size];
+ }
+
+ if (Array != null) {
+ System.arraycopy(Array0, 0, Array, 0, Size);
+ }
+").
+
+%---------------------------------------------------------------------------%
+
+fill(Item, !Array) :-
+ array.bounds(!.Array, Min, Max),
+ do_fill_range(Item, Min, Max, !Array).
+
+fill_range(Item, Lo, Hi, !Array) :-
+ ( if Lo > Hi then
+ unexpected($pred, "empty range")
+ else if not in_bounds(!.Array, Lo) then
+ arg_out_of_bounds_error(!.Array, "second", "fill_range", Lo)
+ else if not in_bounds(!.Array, Hi) then
+ arg_out_of_bounds_error(!.Array, "third", "fill_range", Hi)
+ else
+ do_fill_range(Item, Lo, Hi, !Array)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred do_fill_range(T::in, int::in, int::in,
+ array(T)::array_di, array(T)::array_uo) is det.
+
+:- pragma foreign_proc("Java",
+ do_fill_range(Item::in, Lo::in, Hi::in,
+ Array0::array_di, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Array = jmercury.array.ML_array_fill(Array0, Lo, Hi + 1, Item);
+").
+
+do_fill_range(Item, Lo, Hi, !Array) :-
+ ( if Lo =< Hi then
+ array.unsafe_set(Lo, Item, !Array),
+ do_fill_range(Item, Lo + 1, Hi, !Array)
+ else
+ true
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pragma foreign_decl("C", "
+extern void
+ML_copy_array(MR_ArrayPtr array, MR_ConstArrayPtr old_array);
+").
+
+:- pragma foreign_code("C", "
+// The caller is responsible for allocating the storage for the new array.
+// This routine does the job of copying the array elements.
+void
+ML_copy_array(MR_ArrayPtr array, MR_ConstArrayPtr old_array)
+{
+ // Any changes to this function will probably also require changes to
+ // - array.append below, and
+ // - MR_deep_copy() in runtime/mercury_deep_copy.[ch].
+
+ MR_Integer i;
+ MR_Integer array_size;
+
+ array_size = old_array->size;
+ array->size = array_size;
+ for (i = 0; i < array_size; i++) {
+ array->elements[i] = old_array->elements[i];
+ }
+}
+").
+
+copy(A1) = A2 :-
+ array.copy(A1, A2).
+
+:- pragma foreign_proc("C",
+ copy(Array0::in, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness,
+ sharing(yes(array(T), array(T)), [
+ cel(Array0, [T]) - cel(Array, [T])
+ ])
+ ],
+"
+ ML_alloc_array(Array, Array0->size + 1, MR_ALLOC_ID);
+ ML_copy_array(Array, (MR_ConstArrayPtr) Array0);
+").
+
+:- pragma foreign_proc("C#",
+ copy(Array0::in, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Array = (System.Array) Array0.Clone();
+").
+
+:- pragma foreign_proc("Java",
+ copy(Array0::in, Array::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ int Size;
+
+ if (Array0 == null) {
+ Array = null;
+ Size = 0;
+ } else if (Array0 instanceof int[]) {
+ Size = ((int[]) Array0).length;
+ Array = new int[Size];
+ } else if (Array0 instanceof double[]) {
+ Size = ((double[]) Array0).length;
+ Array = new double[Size];
+ } else if (Array0 instanceof byte[]) {
+ Size = ((byte[]) Array0).length;
+ Array = new byte[Size];
+ } else if (Array0 instanceof short[]) {
+ Size = ((short[]) Array0).length;
+ Array = new short[Size];
+ } else if (Array0 instanceof long[]) {
+ Size = ((long[]) Array0).length;
+ Array = new long[Size];
+ } else if (Array0 instanceof char[]) {
+ Size = ((char[]) Array0).length;
+ Array = new char[Size];
+ } else if (Array0 instanceof float[]) {
+ Size = ((float[]) Array0).length;
+ Array = new float[Size];
+ } else if (Array0 instanceof boolean[]) {
+ Size = ((boolean[]) Array0).length;
+ Array = new boolean[Size];
+ } else {
+ Size = ((Object[]) Array0).length;
+ Array = new Object[Size];
+ }
+
+ if (Array != null) {
+ System.arraycopy(Array0, 0, Array, 0, Size);
+ }
+").
+
+%---------------------------------------------------------------------------%
+
+array(List) = Array :-
+ array.from_list(List, Array).
+
+from_list(List) = Array :-
+ array.from_list(List, Array).
+
+from_list([], Array) :-
+ array.make_empty_array(Array).
+from_list(List, Array) :-
+ List = [Head | Tail],
+ list.length(List, Len),
+ Array0 = array.unsafe_init(Len, Head, 0),
+ array.unsafe_insert_items(Tail, 1, Array0, Array).
+
+%---------------------------------------------------------------------------%
+
+:- pred unsafe_insert_items(list(T)::in, int::in,
+ array(T)::array_di, array(T)::array_uo) is det.
+
+unsafe_insert_items([], _N, !Array).
+unsafe_insert_items([Head | Tail], N, !Array) :-
+ unsafe_set(N, Head, !Array),
+ unsafe_insert_items(Tail, N + 1, !Array).
+
+%---------------------------------------------------------------------------%
+
+from_reverse_list([]) = Array :-
+ array.make_empty_array(Array).
+from_reverse_list(RevList) = Array :-
+ RevList = [Head | Tail],
+ list.length(RevList, Len),
+ Array0 = array.unsafe_init(Len, Head, Len - 1),
+ unsafe_insert_items_reverse(Tail, Len - 2, Array0, Array).
+
+:- pred unsafe_insert_items_reverse(list(T)::in, int::in,
+ array(T)::array_di, array(T)::array_uo) is det.
+
+unsafe_insert_items_reverse([], _, !Array).
+unsafe_insert_items_reverse([Head | Tail], N, !Array) :-
+ unsafe_set(N, Head, !Array),
+ unsafe_insert_items_reverse(Tail, N - 1, !Array).
+
+%---------------------------------------------------------------------------%
+
+to_list(Array) = List :-
+ to_list(Array, List).
+
+to_list(Array, List) :-
+ ( if is_empty(Array) then
+ List = []
+ else
+ bounds(Array, Low, High),
+ fetch_items(Array, Low, High, List)
+ ).
+
+%---------------------------------------------------------------------------%
+
+fetch_items(Array, Low, High) = List :-
+ fetch_items(Array, Low, High, List).
+
+fetch_items(Array, Low, High, List) :-
+ ( if High < Low then
+ % If High is less than Low, then there cannot be any array indexes
+ % within the range Low -> High (inclusive). This can happen when
+ % calling to_list/2 on the empty array, or when iterative over
+ % consecutive contiguous regions of an array. (For an example of
+ % the latter, see ip_get_goals_{before,after} and their callers
+ % in the deep_profiler directory.)
+ List = []
+ else if not in_bounds(Array, Low) then
+ arg_out_of_bounds_error(Array, "second", "fetch_items", Low)
+ else if not in_bounds(Array, High) then
+ arg_out_of_bounds_error(Array, "third", "fetch_items", High)
+ else
+ List = do_foldr_func(func(X, Xs) = [X | Xs], Array, [], Low, High)
+ ).
+
+%---------------------------------------------------------------------------%
+
+map(F, A1) = A2 :-
+ P = (pred(X::in, Y::out) is det :- Y = F(X)),
+ array.map(P, A1, A2).
+
+map(Closure, OldArray, NewArray) :-
+ ( if array.semidet_lookup(OldArray, 0, Elem0) then
+ array.size(OldArray, Size),
+ Closure(Elem0, Elem),
+ NewArray0 = unsafe_init(Size, Elem, 0),
+ array.map_2(1, Size, Closure, OldArray, NewArray0, NewArray)
+ else
+ array.make_empty_array(NewArray)
+ ).
+
+:- pred map_2(int::in, int::in, pred(T1, T2)::in(pred(in, out) is det),
+ array(T1)::in, array(T2)::array_di, array(T2)::array_uo) is det.
+
+map_2(N, Size, Closure, OldArray, !NewArray) :-
+ ( if N >= Size then
+ true
+ else
+ array.unsafe_lookup(OldArray, N, OldElem),
+ Closure(OldElem, NewElem),
+ array.unsafe_set(N, NewElem, !NewArray),
+ map_2(N + 1, Size, Closure, OldArray, !NewArray)
+ ).
+
+%---------------------------------------------------------------------------%
+
+swap(I, J, !Array) :-
+ ( if not in_bounds(!.Array, I) then
+ arg_out_of_bounds_error(!.Array, "first", "array.swap", I)
+ else if not in_bounds(!.Array, J) then
+ arg_out_of_bounds_error(!.Array, "second", "array.swap", J)
+ else
+ unsafe_swap(I, J, !Array)
+ ).
+
+unsafe_swap(I, J, !Array) :-
+ array.unsafe_lookup(!.Array, I, IVal),
+ array.unsafe_lookup(!.Array, J, JVal),
+ array.unsafe_set(I, JVal, !Array),
+ array.unsafe_set(J, IVal, !Array).
+
+%---------------------------------------------------------------------------%
+
+member(A, X) :-
+ nondet_int_in_range(array.min(A), array.max(A), N),
+ array.unsafe_lookup(A, N, X).
+
+%---------------------------------------------------------------------------%
+
+ % array.sort/1 has type specialised versions for arrays of ints and strings
+ % on the expectation that these constitute the common case and are hence
+ % worth providing a fast-path.
+ %
+ % Experiments indicate that type specialisation improves the speed of
+ % array.sort/1 by about 30-40%.
+ %
+:- pragma type_spec(array.sort/1, T = int).
+:- pragma type_spec(array.sort/1, T = string).
+
+sort(A) = samsort_subarray(A, array.min(A), array.max(A)).
+
+:- pragma no_inline(array.sort_fix_2014/0).
+
+sort_fix_2014.
+
+%---------------------------------------------------------------------------%
+
+binary_search(A, SearchX, I) :-
+ array.binary_search(ordering, A, SearchX, I).
+
+binary_search(Cmp, A, SearchX, I) :-
+ Lo = 0,
+ Hi = array.size(A) - 1,
+ binary_search_loop(Cmp, A, SearchX, Lo, Hi, I).
+
+:- pred binary_search_loop(comparison_func(T)::in, array(T)::array_ui,
+ T::in, int::in, int::in, int::out) is semidet.
+
+binary_search_loop(Cmp, A, SearchX, Lo, Hi, I) :-
+ % loop invariant: if SearchX is anywhere in A[0] .. A[array.size(A)-1],
+ % then it is in A[Lo] .. A[Hi].
+ Lo =< Hi,
+ % We calculate Mid this way to avoid overflow.
+ % The right shift by one bit is a fast implementation of division by 2.
+ Mid = Lo + ((Hi - Lo) `unchecked_right_shift` 1),
+ array.unsafe_lookup(A, Mid, MidX),
+ O = Cmp(MidX, SearchX),
+ (
+ O = (>),
+ binary_search_loop(Cmp, A, SearchX, Lo, Mid - 1, I)
+ ;
+ O = (=),
+ I = Mid
+ ;
+ O = (<),
+ binary_search_loop(Cmp, A, SearchX, Mid + 1, Hi, I)
+ ).
+
+%---------------------------------------------------------------------------%
+
+approx_binary_search(A, SearchX, I) :-
+ approx_binary_search(ordering, A, SearchX, I).
+
+approx_binary_search(Cmp, A, SearchX, I) :-
+ Lo = 0,
+ Hi = array.size(A) - 1,
+ approx_binary_search_loop(Cmp, A, SearchX, Lo, Hi, I).
+
+:- pred approx_binary_search_loop(comparison_func(T)::in, array(T)::array_ui,
+ T::in, int::in, int::in, int::out) is semidet.
+
+approx_binary_search_loop(Cmp, A, SearchX, Lo, Hi, I) :-
+ % loop invariant: if SearchX is anywhere in A[0] .. A[array.size(A)-1],
+ % then it is in A[Lo] .. A[Hi].
+ Lo =< Hi,
+ % We calculate Mid this way to avoid overflow.
+ % The right shift by one bit is a fast implementation of division by 2.
+ Mid = Lo + ((Hi - Lo) `unchecked_right_shift` 1),
+ array.unsafe_lookup(A, Mid, MidX),
+ O = Cmp(MidX, SearchX),
+ (
+ O = (>),
+ approx_binary_search_loop(Cmp, A, SearchX, Lo, Mid - 1, I)
+ ;
+ O = (=),
+ I = Mid
+ ;
+ O = (<),
+ ( if
+ ( if Mid < Hi then
+ % We get here only if Mid + 1 cannot exceed Hi,
+ % so the array access is safe.
+ array.unsafe_lookup(A, Mid + 1, MidP1X),
+ (<) = Cmp(SearchX, MidP1X)
+ else
+ Mid = Hi
+ )
+ then
+ I = Mid
+ else
+ approx_binary_search_loop(Cmp, A, SearchX, Mid + 1, Hi, I)
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+
+append(A, B) = C :-
+ SizeA = array.size(A),
+ SizeB = array.size(B),
+ SizeC = SizeA + SizeB,
+ ( if
+ ( if SizeA > 0 then
+ array.lookup(A, 0, InitElem)
+ else if SizeB > 0 then
+ array.lookup(B, 0, InitElem)
+ else
+ fail
+ )
+ then
+ C0 = array.init(SizeC, InitElem),
+ copy_subarray(A, 0, SizeA - 1, 0, C0, C1),
+ copy_subarray(B, 0, SizeB - 1, SizeA, C1, C)
+ else
+ C = array.make_empty_array
+ ).
+
+:- pragma foreign_proc("C",
+ append(ArrayA::in, ArrayB::in) = (ArrayC::array_uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness,
+ sharing(yes(array(T), array(T), array(T)), [
+ cel(ArrayA, [T]) - cel(ArrayC, [T]),
+ cel(ArrayB, [T]) - cel(ArrayC, [T])
+ ])
+ ],
+"
+ MR_Integer sizeC;
+ MR_Integer i;
+ MR_Integer offset;
+
+ sizeC = ArrayA->size + ArrayB->size;
+ ML_alloc_array(ArrayC, sizeC + 1, MR_ALLOC_ID);
+
+ ArrayC->size = sizeC;
+ for (i = 0; i < ArrayA->size; i++) {
+ ArrayC->elements[i] = ArrayA->elements[i];
+ }
+
+ offset = ArrayA->size;
+ for (i = 0; i < ArrayB->size; i++) {
+ ArrayC->elements[offset + i] = ArrayB->elements[i];
+ }
+").
+
+%---------------------------------------------------------------------------%
+
+random_permutation(A0, A, RS0, RS) :-
+ Lo = array.min(A0),
+ Hi = array.max(A0),
+ Sz = array.size(A0),
+ permutation_2(Lo, Lo, Hi, Sz, A0, A, RS0, RS).
+
+:- pred permutation_2(int::in, int::in, int::in, int::in,
+ array(T)::array_di, array(T)::array_uo,
+ random.supply::mdi, random.supply::muo) is det.
+
+permutation_2(I, Lo, Hi, Sz, !A, !RS) :-
+ ( if I > Hi then
+ true
+ else
+ random.random(R, !RS),
+ J = Lo + (R `rem` Sz),
+ swap_elems(I, J, !A),
+ permutation_2(I + 1, Lo, Hi, Sz, !A, !RS)
+ ).
+
+:- pred swap_elems(int::in, int::in, array(T)::array_di, array(T)::array_uo)
+ is det.
+
+swap_elems(I, J, !A) :-
+ array.lookup(!.A, I, XI),
+ array.lookup(!.A, J, XJ),
+ array.unsafe_set(I, XJ, !A),
+ array.unsafe_set(J, XI, !A).
+
+%---------------------------------------------------------------------------%
+
+foldl(Fn, A, X) =
+ do_foldl_func(Fn, A, X, array.min(A), array.max(A)).
+
+:- func do_foldl_func(func(T1, T2) = T2, array(T1), T2, int, int) = T2.
+%:- mode do_foldl_func(func(in, in) = out is det, array_ui, in, in, in)
+% = out is det.
+:- mode do_foldl_func(func(in, in) = out is det, in, in, in, in) = out is det.
+%:- mode do_foldl_func(func(in, di) = uo is det, array_ui, di, in, in)
+% = uo is det.
+:- mode do_foldl_func(func(in, di) = uo is det, in, di, in, in) = uo is det.
+
+do_foldl_func(Fn, A, X, I, Max) =
+ ( if Max < I then
+ X
+ else
+ do_foldl_func(Fn, A, Fn(A ^ unsafe_elem(I), X), I + 1, Max)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldl(P, A, !Acc) :-
+ do_foldl_pred(P, A, array.min(A), array.max(A), !Acc).
+
+:- pred do_foldl_pred(pred(T1, T2, T2), array(T1), int, int, T2, T2).
+:- mode do_foldl_pred(pred(in, in, out) is det, in, in, in, in, out) is det.
+:- mode do_foldl_pred(pred(in, mdi, muo) is det, in, in, in, mdi, muo) is det.
+:- mode do_foldl_pred(pred(in, di, uo) is det, in, in, in, di, uo) is det.
+:- mode do_foldl_pred(pred(in, in, out) is semidet, in, in, in, in, out)
+ is semidet.
+:- mode do_foldl_pred(pred(in, mdi, muo) is semidet, in, in, in, mdi, muo)
+ is semidet.
+:- mode do_foldl_pred(pred(in, di, uo) is semidet, in, in, in, di, uo)
+ is semidet.
+
+do_foldl_pred(P, A, I, Max, !Acc) :-
+ ( if Max < I then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc),
+ do_foldl_pred(P, A, I + 1, Max, !Acc)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldl2(P, A, !Acc1, !Acc2) :-
+ do_foldl2(P, array.min(A), array.max(A), A, !Acc1, !Acc2).
+
+:- pred do_foldl2(pred(T1, T2, T2, T3, T3), int, int, array(T1), T2, T2,
+ T3, T3).
+:- mode do_foldl2(pred(in, in, out, in, out) is det, in, in, in, in, out,
+ in, out) is det.
+:- mode do_foldl2(pred(in, in, out, mdi, muo) is det, in, in, in, in, out,
+ mdi, muo) is det.
+:- mode do_foldl2(pred(in, in, out, di, uo) is det, in, in, in, in, out,
+ di, uo) is det.
+:- mode do_foldl2(pred(in, in, out, in, out) is semidet, in, in, in, in, out,
+ in, out) is semidet.
+:- mode do_foldl2(pred(in, in, out, mdi, muo) is semidet, in, in, in, in, out,
+ mdi, muo) is semidet.
+:- mode do_foldl2(pred(in, in, out, di, uo) is semidet, in, in, in, in, out,
+ di, uo) is semidet.
+
+do_foldl2(P, I, Max, A, !Acc1, !Acc2) :-
+ ( if Max < I then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2),
+ do_foldl2(P, I + 1, Max, A, !Acc1, !Acc2)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldl3(P, A, !Acc1, !Acc2, !Acc3) :-
+ do_foldl3(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3).
+
+:- pred do_foldl3(pred(T1, T2, T2, T3, T3, T4, T4), int, int, array(T1),
+ T2, T2, T3, T3, T4, T4).
+:- mode do_foldl3(pred(in, in, out, in, out, in, out) is det, in, in, in,
+ in, out, in, out, in, out) is det.
+:- mode do_foldl3(pred(in, in, out, in, out, mdi, muo) is det, in, in, in,
+ in, out, in, out, mdi, muo) is det.
+:- mode do_foldl3(pred(in, in, out, in, out, di, uo) is det, in, in, in,
+ in, out, in, out, di, uo) is det.
+:- mode do_foldl3(pred(in, in, out, in, out, in, out) is semidet, in, in, in,
+ in, out, in, out, in, out) is semidet.
+:- mode do_foldl3(pred(in, in, out, in, out, mdi, muo) is semidet, in, in, in,
+ in, out, in, out, mdi, muo) is semidet.
+:- mode do_foldl3(pred(in, in, out, in, out, di, uo) is semidet, in, in, in,
+ in, out, in, out, di, uo) is semidet.
+
+do_foldl3(P, I, Max, A, !Acc1, !Acc2, !Acc3) :-
+ ( if Max < I then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3),
+ do_foldl3(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldl4(P, A, !Acc1, !Acc2, !Acc3, !Acc4) :-
+ do_foldl4(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4).
+
+:- pred do_foldl4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), int, int,
+ array(T1), T2, T2, T3, T3, T4, T4, T5, T5).
+:- mode do_foldl4(pred(in, in, out, in, out, in, out, in, out) is det, in, in,
+ in, in, out, in, out, in, out, in, out) is det.
+:- mode do_foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is det, in, in,
+ in, in, out, in, out, in, out, mdi, muo) is det.
+:- mode do_foldl4(pred(in, in, out, in, out, in, out, di, uo) is det, in, in,
+ in, in, out, in, out, in, out, di, uo) is det.
+:- mode do_foldl4(pred(in, in, out, in, out, in, out, in, out) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out) is semidet.
+:- mode do_foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, in, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode do_foldl4(pred(in, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, in, in, out, in, out, in, out, di, uo) is semidet.
+
+do_foldl4(P, I, Max, A, !Acc1, !Acc2, !Acc3, !Acc4) :-
+ ( if Max < I then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4),
+ do_foldl4(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3, !Acc4)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldl5(P, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :-
+ do_foldl5(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4,
+ !Acc5).
+
+:- pred do_foldl5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6),
+ int, int, array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6).
+:- mode do_foldl5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is det,
+ in, in, in, in, out, in, out, in, out, in, out, in, out) is det.
+:- mode do_foldl5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det,
+ in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is det.
+:- mode do_foldl5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is det,
+ in, in, in, in, out, in, out, in, out, in, out, di, uo) is det.
+:- mode do_foldl5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out, in, out) is semidet.
+:- mode do_foldl5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode do_foldl5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out, di, uo) is semidet.
+
+do_foldl5(P, I, Max, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :-
+ ( if Max < I then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4, !Acc5),
+ do_foldl5(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldr(Fn, A, X) =
+ do_foldr_func(Fn, A, X, array.min(A), array.max(A)).
+
+:- func do_foldr_func(func(T1, T2) = T2, array(T1), T2, int, int) = T2.
+%:- mode do_foldr_func(func(in, in) = out is det, array_ui, in, in, in)
+% = out is det.
+:- mode do_foldr_func(func(in, in) = out is det, in, in, in, in) = out is det.
+%:- mode do_foldr_func(func(in, di) = uo is det, array_ui, di, in, in)
+% = uo is det.
+:- mode do_foldr_func(func(in, di) = uo is det, in, di, in, in) = uo is det.
+
+do_foldr_func(Fn, A, X, Min, I) =
+ ( if I < Min then
+ X
+ else
+ do_foldr_func(Fn, A, Fn(A ^ unsafe_elem(I), X), Min, I - 1)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldr(P, A, !Acc) :-
+ do_foldr_pred(P, array.min(A), array.max(A), A, !Acc).
+
+:- pred do_foldr_pred(pred(T1, T2, T2), int, int, array(T1), T2, T2).
+:- mode do_foldr_pred(pred(in, in, out) is det, in, in, in, in, out) is det.
+:- mode do_foldr_pred(pred(in, mdi, muo) is det, in, in, in, mdi, muo) is det.
+:- mode do_foldr_pred(pred(in, di, uo) is det, in, in, in, di, uo) is det.
+:- mode do_foldr_pred(pred(in, in, out) is semidet, in, in, in, in, out)
+ is semidet.
+:- mode do_foldr_pred(pred(in, mdi, muo) is semidet, in, in, in, mdi, muo)
+ is semidet.
+:- mode do_foldr_pred(pred(in, di, uo) is semidet, in, in, in, di, uo)
+ is semidet.
+
+do_foldr_pred(P, Min, I, A, !Acc) :-
+ ( if I < Min then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc),
+ do_foldr_pred(P, Min, I - 1, A, !Acc)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldr2(P, A, !Acc1, !Acc2) :-
+ do_foldr2(P, array.min(A), array.max(A), A, !Acc1, !Acc2).
+
+:- pred do_foldr2(pred(T1, T2, T2, T3, T3), int, int, array(T1), T2, T2,
+ T3, T3).
+:- mode do_foldr2(pred(in, in, out, in, out) is det, in, in, in, in, out,
+ in, out) is det.
+:- mode do_foldr2(pred(in, in, out, mdi, muo) is det, in, in, in, in, out,
+ mdi, muo) is det.
+:- mode do_foldr2(pred(in, in, out, di, uo) is det, in, in, in, in, out,
+ di, uo) is det.
+:- mode do_foldr2(pred(in, in, out, in, out) is semidet, in, in, in, in, out,
+ in, out) is semidet.
+:- mode do_foldr2(pred(in, in, out, mdi, muo) is semidet, in, in, in, in, out,
+ mdi, muo) is semidet.
+:- mode do_foldr2(pred(in, in, out, di, uo) is semidet, in, in, in, in, out,
+ di, uo) is semidet.
+
+do_foldr2(P, Min, I, A, !Acc1, !Acc2) :-
+ ( if I < Min then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2),
+ do_foldr2(P, Min, I - 1, A, !Acc1, !Acc2)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldr3(P, A, !Acc1, !Acc2, !Acc3) :-
+ do_foldr3(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3).
+
+:- pred do_foldr3(pred(T1, T2, T2, T3, T3, T4, T4), int, int, array(T1),
+ T2, T2, T3, T3, T4, T4).
+:- mode do_foldr3(pred(in, in, out, in, out, in, out) is det, in, in, in,
+ in, out, in, out, in, out) is det.
+:- mode do_foldr3(pred(in, in, out, in, out, mdi, muo) is det, in, in, in,
+ in, out, in, out, mdi, muo) is det.
+:- mode do_foldr3(pred(in, in, out, in, out, di, uo) is det, in, in, in,
+ in, out, in, out, di, uo) is det.
+:- mode do_foldr3(pred(in, in, out, in, out, in, out) is semidet, in, in, in,
+ in, out, in, out, in, out) is semidet.
+:- mode do_foldr3(pred(in, in, out, in, out, mdi, muo) is semidet, in, in, in,
+ in, out, in, out, mdi, muo) is semidet.
+:- mode do_foldr3(pred(in, in, out, in, out, di, uo) is semidet, in, in, in,
+ in, out, in, out, di, uo) is semidet.
+
+do_foldr3(P, Min, I, A, !Acc1, !Acc2, !Acc3) :-
+ ( if I < Min then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3),
+ do_foldr3(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldr4(P, A, !Acc1, !Acc2, !Acc3, !Acc4) :-
+ do_foldr4(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4).
+
+:- pred do_foldr4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), int, int,
+ array(T1), T2, T2, T3, T3, T4, T4, T5, T5).
+:- mode do_foldr4(pred(in, in, out, in, out, in, out, in, out) is det, in, in,
+ in, in, out, in, out, in, out, in, out) is det.
+:- mode do_foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is det, in, in,
+ in, in, out, in, out, in, out, mdi, muo) is det.
+:- mode do_foldr4(pred(in, in, out, in, out, in, out, di, uo) is det, in, in,
+ in, in, out, in, out, in, out, di, uo) is det.
+:- mode do_foldr4(pred(in, in, out, in, out, in, out, in, out) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out) is semidet.
+:- mode do_foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, in, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode do_foldr4(pred(in, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, in, in, out, in, out, in, out, di, uo) is semidet.
+
+do_foldr4(P, Min, I, A, !Acc1, !Acc2, !Acc3, !Acc4) :-
+ ( if I < Min then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4),
+ do_foldr4(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3, !Acc4)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldr5(P, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :-
+ do_foldr5(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4,
+ !Acc5).
+
+:- pred do_foldr5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6),
+ int, int, array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6).
+:- mode do_foldr5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is det,
+ in, in, in, in, out, in, out, in, out, in, out, in, out) is det.
+:- mode do_foldr5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det,
+ in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is det.
+:- mode do_foldr5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is det,
+ in, in, in, in, out, in, out, in, out, in, out, di, uo) is det.
+:- mode do_foldr5(
+ pred(in, in, out, in, out, in, out, in, out, in, out) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out, in, out) is semidet.
+:- mode do_foldr5(
+ pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is semidet.
+:- mode do_foldr5(
+ pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet,
+ in, in, in, in, out, in, out, in, out, in, out, di, uo) is semidet.
+
+do_foldr5(P, Min, I, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :-
+ ( if I < Min then
+ true
+ else
+ P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4, !Acc5),
+ do_foldr5(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5)
+ ).
+
+%---------------------------------------------------------------------------%
+
+foldl_corresponding(P, A, B, !Acc) :-
+ MaxA = array.max(A),
+ MaxB = array.max(B),
+ ( if MaxA = MaxB then
+ do_foldl_corresponding(P, 0, MaxA, A, B, !Acc)
+ else
+ unexpected($pred, "mismatched array sizes")
+ ).
+
+:- pred do_foldl_corresponding(pred(T1, T2, T3, T3), int, int,
+ array(T1), array(T2), T3, T3).
+:- mode do_foldl_corresponding(in(pred(in, in, in, out) is det), in, in,
+ in, in, in, out) is det.
+:- mode do_foldl_corresponding(in(pred(in, in, mdi, muo) is det), in, in,
+ in, in, mdi, muo) is det.
+:- mode do_foldl_corresponding(in(pred(in, in, di, uo) is det), in, in,
+ in, in, di, uo) is det.
+:- mode do_foldl_corresponding(in(pred(in, in, in, out) is semidet), in, in,
+ in, in, in, out) is semidet.
+:- mode do_foldl_corresponding(in(pred(in, in, mdi, muo) is semidet), in, in,
+ in, in, mdi, muo) is semidet.
+:- mode do_foldl_corresponding(in(pred(in, in, di, uo) is semidet), in, in,
+ in, in, di, uo) is semidet.
+
+do_foldl_corresponding(P, I, Max, A, B, !Acc) :-
+ ( if Max < I then
+ true
+ else
+ P(A ^ unsafe_elem(I), B ^ unsafe_elem(I), !Acc),
+ do_foldl_corresponding(P, I + 1, Max, A, B, !Acc)
+ ).
+
+foldl2_corresponding(P, A, B, !Acc1, !Acc2) :-
+ MaxA = array.max(A),
+ MaxB = array.max(B),
+ ( if MaxA = MaxB then
+ do_foldl2_corresponding(P, 0, MaxA, A, B, !Acc1, !Acc2)
+ else
+ unexpected($pred, "mismatched array sizes")
+ ).
+
+:- pred do_foldl2_corresponding(pred(T1, T2, T3, T3, T4, T4), int, int,
+ array(T1), array(T2), T3, T3, T4, T4).
+:- mode do_foldl2_corresponding(in(pred(in, in, in, out, in, out) is det),
+ in, in, in, in, in, out, in, out) is det.
+:- mode do_foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is det),
+ in, in, in, in, in, out, mdi, muo) is det.
+:- mode do_foldl2_corresponding(in(pred(in, in, in, out, di, uo) is det),
+ in, in, in, in, in, out, di, uo) is det.
+:- mode do_foldl2_corresponding(in(pred(in, in, in, out, in, out) is semidet),
+ in, in, in, in, in, out, in, out) is semidet.
+:- mode do_foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is semidet),
+ in, in, in, in, in, out, mdi, muo) is semidet.
+:- mode do_foldl2_corresponding(in(pred(in, in, in, out, di, uo) is semidet),
+ in, in, in, in, in, out, di, uo) is semidet.
+
+do_foldl2_corresponding(P, I, Max, A, B, !Acc1, !Acc2) :-
+ ( if Max < I then
+ true
+ else
+ P(A ^ unsafe_elem(I), B ^ unsafe_elem(I), !Acc1, !Acc2),
+ do_foldl2_corresponding(P, I + 1, Max, A, B, !Acc1, !Acc2)
+ ).
+
+%---------------------------------------------------------------------------%
+
+map_foldl(P, A, B, !Acc) :-
+ N = array.size(A),
+ ( if N =< 0 then
+ B = array.make_empty_array
+ else
+ array.unsafe_lookup(A, 0, X),
+ P(X, Y, !Acc),
+ B1 = unsafe_init(N, Y, 0),
+ map_foldl_2(P, 1, A, B1, B, !Acc)
+ ).
+
+:- pred map_foldl_2(pred(T1, T2, T3, T3),
+ int, array(T1), array(T2), array(T2), T3, T3).
+:- mode map_foldl_2(in(pred(in, out, in, out) is det),
+ in, in, array_di, array_uo, in, out) is det.
+:- mode map_foldl_2(in(pred(in, out, mdi, muo) is det),
+ in, in, array_di, array_uo, mdi, muo) is det.
+:- mode map_foldl_2(in(pred(in, out, di, uo) is det),
+ in, in, array_di, array_uo, di, uo) is det.
+:- mode map_foldl_2(in(pred(in, out, in, out) is semidet),
+ in, in, array_di, array_uo, in, out) is semidet.
+
+map_foldl_2(P, I, A, !B, !Acc) :-
+ ( if I < array.size(A) then
+ array.unsafe_lookup(A, I, X),
+ P(X, Y, !Acc),
+ array.unsafe_set(I, Y, !B),
+ map_foldl_2(P, I + 1, A, !B, !Acc)
+ else
+ true
+ ).
+
+%---------------------------------------------------------------------------%
+
+map_corresponding_foldl(P, A, B, C, !Acc) :-
+ SizeA = array.size(A),
+ SizeB = array.size(B),
+ ( if SizeA \= SizeB then
+ unexpected($pred, "mismatched array sizes")
+ else if SizeA =< 0 then
+ C = array.make_empty_array
+ else
+ array.unsafe_lookup(A, 0, X),
+ array.unsafe_lookup(B, 0, Y),
+ P(X, Y, Z, !Acc),
+ C1 = unsafe_init(SizeA, Z, 0),
+ map_corresponding_foldl_2(P, 1, SizeA, A, B, C1, C, !Acc)
+ ).
+
+:- pred map_corresponding_foldl_2(pred(T1, T2, T3, T4, T4),
+ int, int, array(T1), array(T2), array(T3), array(T3), T4, T4).
+:- mode map_corresponding_foldl_2(
+ in(pred(in, in, out, in, out) is det),
+ in, in, in, in, array_di, array_uo, in, out) is det.
+:- mode map_corresponding_foldl_2(
+ in(pred(in, in, out, mdi, muo) is det),
+ in, in, in, in, array_di, array_uo, mdi, muo) is det.
+:- mode map_corresponding_foldl_2(
+ in(pred(in, in, out, di, uo) is det),
+ in, in, in, in, array_di, array_uo, di, uo) is det.
+:- mode map_corresponding_foldl_2(
+ in(pred(in, in, out, in, out) is semidet),
+ in, in, in, in, array_di, array_uo, in, out) is semidet.
+:- mode map_corresponding_foldl_2(
+ in(pred(in, in, out, mdi, muo) is semidet),
+ in, in, in, in, array_di, array_uo, mdi, muo) is semidet.
+:- mode map_corresponding_foldl_2(
+ in(pred(in, in, out, di, uo) is semidet),
+ in, in, in, in, array_di, array_uo, di, uo) is semidet.
+
+map_corresponding_foldl_2(P, I, N, A, B, !C, !Acc) :-
+ ( if I < N then
+ array.unsafe_lookup(A, I, X),
+ array.unsafe_lookup(B, I, Y),
+ P(X, Y, Z, !Acc),
+ array.unsafe_set(I, Z, !C),
+ map_corresponding_foldl_2(P, I + 1, N, A, B, !C, !Acc)
+ else
+ true
+ ).
+
+%---------------------------------------------------------------------------%
+
+all_true(Pred, Array) :-
+ do_all_true(Pred, array.min(Array), array.max(Array), Array).
+
+:- pred do_all_true(pred(T), int, int, array(T)).
+%:- mode do_all_true(in(pred(in) is semidet), in, in, array_ui) is semidet.
+:- mode do_all_true(in(pred(in) is semidet), in, in, in) is semidet.
+
+do_all_true(Pred, I, UB, Array) :-
+ ( if I =< UB then
+ array.unsafe_lookup(Array, I, Elem),
+ Pred(Elem),
+ do_all_true(Pred, I + 1, UB, Array)
+ else
+ true
+ ).
+
+all_false(Pred, Array) :-
+ do_all_false(Pred, array.min(Array), array.max(Array), Array).
+
+:- pred do_all_false(pred(T), int, int, array(T)).
+%:- mode do_all_false(in(pred(in) is semidet), in, in, array_ui) is semidet.
+:- mode do_all_false(in(pred(in) is semidet), in, in, in) is semidet.
+
+do_all_false(Pred, I, UB, Array) :-
+ ( if I =< UB then
+ array.unsafe_lookup(Array, I, Elem),
+ not Pred(Elem),
+ do_all_false(Pred, I + 1, UB, Array)
+ else
+ true
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+ % SAMsort (smooth applicative merge) invented by R.A. O'Keefe.
+ %
+ % SAMsort is a mergesort variant that works by identifying contiguous
+ % monotonic sequences and merging them, thereby taking advantage of
+ % any existing order in the input sequence.
+ %
+:- func samsort_subarray(array(T)::array_di, int::in, int::in) =
+ (array(T)::array_uo) is det.
+
+:- pragma type_spec(samsort_subarray/3, T = int).
+:- pragma type_spec(samsort_subarray/3, T = string).
+
+samsort_subarray(A0, Lo, Hi) = A :-
+ samsort_up(0, array.copy(A0), A, A0, _, Lo, Hi, Lo).
+
+ % samsort_up(N, A0, A, B0, B, Lo, Hi, I):
+ %
+ % Precondition:
+ % We are N levels from the bottom (leaf nodes) of the tree.
+ % A0 is sorted from Lo .. I - 1.
+ % A0 and B0 are identical from I .. Hi.
+ % Postcondition:
+ % A is sorted from Lo .. Hi.
+ %
+:- pred samsort_up(int::in, array(T)::array_di, array(T)::array_uo,
+ array(T)::array_di, array(T)::array_uo, int::in, int::in, int::in) is det.
+
+:- pragma type_spec(samsort_up/8, T = int).
+:- pragma type_spec(samsort_up/8, T = string).
+
+samsort_up(N, A0, A, B0, B, Lo, Hi, I) :-
+ trace [compile_time(flag("array_sort"))] (
+ verify_sorted(A0, Lo, I - 1),
+ verify_identical(A0, B0, I, Hi)
+ ),
+ ( if I > Hi then
+ A = A0,
+ B = B0
+ % A is sorted from Lo .. Hi.
+ else if N > 0 then
+ % B0 and A0 are identical from I .. Hi.
+ samsort_down(N - 1, B0, B1, A0, A1, I, Hi, J),
+ % A1 is sorted from I .. J - 1.
+ % B1 and A1 are identical from J .. Hi.
+
+ merge_subarrays(A1, Lo, I - 1, I, J - 1, Lo, B1, B2),
+ A2 = A1,
+
+ % B2 is sorted from Lo .. J - 1.
+ % B2 and A2 are identical from J .. Hi.
+ samsort_up(N + 1, B2, B3, A2, A3, Lo, Hi, J),
+ % B3 is sorted from Lo .. Hi.
+
+ A = B3,
+ B = A3
+ % A is sorted from Lo .. Hi.
+ else
+ % N = 0, I = Lo
+ copy_run_ascending(A0, B0, B1, Lo, Hi, J),
+
+ % B1 is sorted from Lo .. J - 1.
+ % B1 and A0 are identical from J .. Hi.
+ samsort_up(N + 1, B1, B2, A0, A2, Lo, Hi, J),
+ % B2 is sorted from Lo .. Hi.
+
+ A = B2,
+ B = A2
+ % A is sorted from Lo .. Hi.
+ ),
+ trace [compile_time(flag("array_sort"))] (
+ verify_sorted(A, Lo, Hi)
+ ).
+
+ % samsort_down(N, A0, A, B0, B, Lo, Hi, I):
+ %
+ % Precondition:
+ % We are N levels from the bottom (leaf nodes) of the tree.
+ % A0 and B0 are identical from Lo .. Hi.
+ % Postcondition:
+ % B is sorted from Lo .. I - 1.
+ % A and B are identical from I .. Hi.
+ %
+:- pred samsort_down(int::in, array(T)::array_di, array(T)::array_uo,
+ array(T)::array_di, array(T)::array_uo, int::in, int::in, int::out) is det.
+
+:- pragma type_spec(samsort_down/8, T = int).
+:- pragma type_spec(samsort_down/8, T = string).
+
+samsort_down(N, A0, A, B0, B, Lo, Hi, I) :-
+ trace [compile_time(flag("array_sort"))] (
+ verify_identical(A0, B0, Lo, Hi)
+ ),
+ ( if Lo > Hi then
+ A = A0,
+ B = B0,
+ I = Lo
+ % B is sorted from Lo .. I - 1.
+ else if N > 0 then
+ samsort_down(N - 1, B0, B1, A0, A1, Lo, Hi, J),
+ samsort_down(N - 1, B1, B2, A1, A2, J, Hi, I),
+ % A2 is sorted from Lo .. J - 1.
+ % A2 is sorted from J .. I - 1.
+ A = A2,
+ merge_subarrays(A2, Lo, J - 1, J, I - 1, Lo, B2, B)
+ % B is sorted from Lo .. I - 1.
+ else
+ A = A0,
+ copy_run_ascending(A0, B0, B, Lo, Hi, I)
+ % B is sorted from Lo .. I - 1.
+ ),
+ trace [compile_time(flag("array_sort"))] (
+ verify_sorted(B, Lo, I - 1),
+ verify_identical(A, B, I, Hi)
+ ).
+
+:- pred verify_sorted(array(T)::array_ui, int::in, int::in) is det.
+
+verify_sorted(A, Lo, Hi) :-
+ ( if Lo >= Hi then
+ true
+ else if compare((<), A ^ elem(Lo + 1), A ^ elem(Lo)) then
+ unexpected($pred, "array range not sorted")
+ else
+ verify_sorted(A, Lo + 1, Hi)
+ ).
+
+:- pred verify_identical(array(T)::array_ui, array(T)::array_ui,
+ int::in, int::in) is det.
+
+verify_identical(A, B, Lo, Hi) :-
+ ( if Lo > Hi then
+ true
+ else if A ^ elem(Lo) = B ^ elem(Lo) then
+ verify_identical(A, B, Lo + 1, Hi)
+ else
+ unexpected($pred, "array ranges not identical")
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred copy_run_ascending(array(T)::array_ui,
+ array(T)::array_di, array(T)::array_uo, int::in, int::in, int::out) is det.
+
+:- pragma type_spec(copy_run_ascending/6, T = int).
+:- pragma type_spec(copy_run_ascending/6, T = string).
+
+copy_run_ascending(A, !B, Lo, Hi, I) :-
+ ( if
+ Lo < Hi,
+ compare((>), A ^ elem(Lo), A ^ elem(Lo + 1))
+ then
+ I = search_until((<), A, Lo, Hi),
+ copy_subarray_reverse(A, Lo, I - 1, I - 1, !B)
+ else
+ I = search_until((>), A, Lo, Hi),
+ copy_subarray(A, Lo, I - 1, Lo, !B)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- func search_until(comparison_result::in, array(T)::array_ui,
+ int::in, int::in) = (int::out) is det.
+
+:- pragma type_spec(search_until/4, T = int).
+:- pragma type_spec(search_until/4, T = string).
+
+search_until(R, A, Lo, Hi) =
+ ( if
+ Lo < Hi,
+ not compare(R, A ^ elem(Lo), A ^ elem(Lo + 1))
+ then
+ search_until(R, A, Lo + 1, Hi)
+ else
+ Lo + 1
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % Assigns the subarray A[Lo..Hi] to B[InitI..Final], where InitI
+ % is the initial value of I, and FinalI = InitI + (Ho - Lo + 1).
+ % In this version, I is ascending, so B[InitI] gets A[Lo]
+ %
+:- pred copy_subarray(array(T)::array_ui, int::in, int::in, int::in,
+ array(T)::array_di, array(T)::array_uo) is det.
+
+:- pragma type_spec(copy_subarray/6, T = int).
+:- pragma type_spec(copy_subarray/6, T = string).
+
+copy_subarray(A, Lo, Hi, I, !B) :-
+ ( if Lo =< Hi then
+ array.lookup(A, Lo, X),
+ % XXX Would it be safe to replace this with array.unsafe_set?
+ array.set(I, X, !B),
+ copy_subarray(A, Lo + 1, Hi, I + 1, !B)
+ else
+ true
+ ).
+
+ % Assigns the subarray A[Lo..Hi] to B[InitI..Final], where InitI
+ % is the initial value of I, and FinalI = InitI - (Ho - Lo + 1).
+ % In this version, I is descending, so B[InitI] gets A[Hi].
+ %
+:- pred copy_subarray_reverse(array(T)::array_ui, int::in, int::in, int::in,
+ array(T)::array_di, array(T)::array_uo) is det.
+
+:- pragma type_spec(copy_subarray_reverse/6, T = int).
+:- pragma type_spec(copy_subarray_reverse/6, T = string).
+
+copy_subarray_reverse(A, Lo, Hi, I, !B) :-
+ ( if Lo =< Hi then
+ array.lookup(A, Lo, X),
+ % XXX Would it be safe to replace this with array.unsafe_set?
+ array.set(I, X, !B),
+ copy_subarray_reverse(A, Lo + 1, Hi, I - 1, !B)
+ else
+ true
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % merges the two sorted consecutive subarrays Lo1 .. Hi1 and Lo2 .. Hi2
+ % from A into the subarray starting at I in B.
+ %
+:- pred merge_subarrays(array(T)::array_ui,
+ int::in, int::in, int::in, int::in, int::in,
+ array(T)::array_di, array(T)::array_uo) is det.
+
+:- pragma type_spec(merge_subarrays/8, T = int).
+:- pragma type_spec(merge_subarrays/8, T = string).
+
+merge_subarrays(A, Lo1, Hi1, Lo2, Hi2, I, !B) :-
+ ( if Lo1 > Hi1 then
+ copy_subarray(A, Lo2, Hi2, I, !B)
+ else if Lo2 > Hi2 then
+ copy_subarray(A, Lo1, Hi1, I, !B)
+ else
+ array.lookup(A, Lo1, X1),
+ array.lookup(A, Lo2, X2),
+ compare(R, X1, X2),
+ (
+ R = (<),
+ array.set(I, X1, !B),
+ merge_subarrays(A, Lo1 + 1, Hi1, Lo2, Hi2, I + 1, !B)
+ ;
+ R = (=),
+ array.set(I, X1, !B),
+ merge_subarrays(A, Lo1 + 1, Hi1, Lo2, Hi2, I + 1, !B)
+ ;
+ R = (>),
+ array.set(I, X2, !B),
+ merge_subarrays(A, Lo1, Hi1, Lo2 + 1, Hi2, I + 1, !B)
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % Throw an exception indicating an array bounds error.
+ %
+:- pred out_of_bounds_error(array(T), int, string).
+%:- mode out_of_bounds_error(array_ui, in, in) is erroneous.
+:- mode out_of_bounds_error(in, in, in) is erroneous.
+
+out_of_bounds_error(Array, Index, PredName) :-
+ % Note: we deliberately do not include the array element type name in the
+ % error message here, for performance reasons: using the type name could
+ % prevent the compiler from optimizing away the construction of the
+ % type_info in the caller, because it would prevent unused argument
+ % elimination. Performance is important here, because array.set and
+ % array.lookup are likely to be used in the inner loops of
+ % performance-critical applications.
+ array.bounds(Array, Min, Max),
+ string.format("%s: index %d not in range [%d, %d]",
+ [s(PredName), i(Index), i(Min), i(Max)], Msg),
+ throw(array.index_out_of_bounds(Msg)).
+
+ % Like the above, but for use in cases where the are multiple arguments
+ % that correspond to array indices.
+ %
+:- pred arg_out_of_bounds_error(array(T), string, string, int).
+:- mode arg_out_of_bounds_error(in, in, in, in) is erroneous.
+
+arg_out_of_bounds_error(Array, ArgPosn, PredName, Index) :-
+ array.bounds(Array, Min, Max),
+ string.format("%s argument of %s: index %d not in range [%d, %d]",
+ [s(ArgPosn), s(PredName), i(Index), i(Min), i(Max)], Msg),
+ throw(array.index_out_of_bounds(Msg)).
+
+%---------------------------------------------------------------------------%
+
+det_least_index(A) = Index :-
+ ( if array.is_empty(A) then
+ unexpected($pred, "empty array")
+ else
+ Index = array.min(A)
+ ).
+
+semidet_least_index(A) = Index :-
+ ( if array.is_empty(A) then
+ fail
+ else
+ Index = array.min(A)
+ ).
+
+%---------------------------------------------------------------------------%
+
+det_greatest_index(A) = Index :-
+ ( if array.is_empty(A) then
+ unexpected($pred, "empty array")
+ else
+ Index = array.max(A)
+ ).
+
+semidet_greatest_index(A) = Index :-
+ ( if array.is_empty(A) then
+ fail
+ else
+ Index = array.max(A)
+ ).
+
+%---------------------------------------------------------------------------%
+
+array_to_doc(A) =
+ indent([str("array(["), array_to_doc_2(0, A), str("])")]).
+
+:- func array_to_doc_2(int, array(T)) = doc.
+
+array_to_doc_2(I, A) =
+ ( if I > array.max(A) then
+ str("")
+ else
+ docs([
+ format_arg(format(A ^ elem(I))),
+ ( if I = array.max(A) then str("") else group([str(", "), nl]) ),
+ format_susp((func) = array_to_doc_2(I + 1, A))
+ ])
+ ).
+
+%---------------------------------------------------------------------------%
+
+dynamic_cast_to_array(X, A) :-
+ % If X is an array then it has a type with one type argument.
+ [ArgTypeDesc] = type_args(type_of(X)),
+
+ % Convert ArgTypeDesc to a type variable ArgType.
+ (_ `with_type` ArgType) `has_type` ArgTypeDesc,
+
+ % Constrain the type of A to be array(ArgType) and do the cast.
+ dynamic_cast(X, A `with_type` array(ArgType)).
+
+%---------------------------------------------------------------------------%
+:- end_module array.
+%---------------------------------------------------------------------------%
--
2.26.3
next prev parent reply other threads:[~2021-03-29 11:53 UTC|newest]
Thread overview: 27+ messages / expand[flat|nested] mbox.gz Atom feed top
[not found] <25b8baef-11f2-7079-69d8-3207a24658fc@gmail.com>
2021-03-26 7:09 ` bug#47408: Emacs etags support for Mercury [v0.2] fabrice nicol
2021-03-27 10:51 ` bug#47408: Etags support for Mercury [v0.3] fabrice nicol
2021-03-28 13:11 ` Eli Zaretskii
2021-03-28 15:49 ` fabrice nicol
2021-03-28 16:22 ` Eli Zaretskii
2021-03-29 11:53 ` fabrice nicol [this message]
[not found] ` <70503251-f8ea-9006-b7e7-b13b93bb71de@gmail.com>
2021-05-15 8:31 ` bug#47408: Fwd: bug#47408: Etags support for Mercury [v0.4] Eli Zaretskii
[not found] ` <53162dfb-0715-3077-78d1-3a8340943f2f@gmail.com>
2021-05-29 8:01 ` Eli Zaretskii
[not found] ` <CANTSrJtDMu=4SWUcBRt51X8n42mOfB6_sFi8mNoZ0YgYdtE-DA@mail.gmail.com>
2021-05-29 10:22 ` Eli Zaretskii
2021-06-01 2:38 ` bug#47408: Etags support for Mercury [v0.5] fabrice nicol
2021-06-06 9:48 ` Eli Zaretskii
2021-06-06 13:34 ` fabrice nicol
2021-06-06 18:18 ` Francesco Potortì
2021-06-06 20:49 ` fabrice nicol
2021-06-06 21:04 ` Francesco Potortì
2021-06-07 12:13 ` Eli Zaretskii
2021-06-08 0:38 ` Fabrice Nicol
2021-06-08 10:53 ` Francesco Potortì
2021-06-08 11:47 ` Eli Zaretskii
2021-06-08 12:47 ` Francesco Potortì
2021-06-10 13:59 ` Eli Zaretskii
2021-06-10 16:52 ` fabrice nicol
2021-06-10 17:05 ` Francesco Potortì
2021-06-10 17:20 ` Eli Zaretskii
2021-06-10 19:15 ` Eli Zaretskii
2021-06-10 20:39 ` bug#47408: Etags support for Mercury -- fix explicit tags for existentially-quantified procedures fabrice nicol
2021-06-11 5:56 ` Eli Zaretskii
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=b59da901-4df7-843f-da03-5aa184d1a992@gmail.com \
--to=fabrnicol@gmail.com \
--cc=47408@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).