From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Eli Zaretskii Newsgroups: gmane.emacs.bugs Subject: bug#47408: Fwd: bug#47408: Etags support for Mercury [v0.4] Date: Sat, 15 May 2021 11:31:47 +0300 Message-ID: <838s4gxurw.fsf@gnu.org> References: <70503251-f8ea-9006-b7e7-b13b93bb71de@gmail.com> Mime-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="35576"; mail-complaints-to="usenet@ciao.gmane.io" Cc: 47408@debbugs.gnu.org To: fabrice nicol Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sat May 15 10:32:14 2021 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1lhpiY-00092P-7J for geb-bug-gnu-emacs@m.gmane-mx.org; Sat, 15 May 2021 10:32:14 +0200 Original-Received: from localhost ([::1]:58798 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lhpiW-0003C0-U2 for geb-bug-gnu-emacs@m.gmane-mx.org; Sat, 15 May 2021 04:32:12 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:49122) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lhpiM-0003Bj-HR for bug-gnu-emacs@gnu.org; Sat, 15 May 2021 04:32:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:35942) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lhpiM-0007aW-A2 for bug-gnu-emacs@gnu.org; Sat, 15 May 2021 04:32:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lhpiM-0002oT-5k for bug-gnu-emacs@gnu.org; Sat, 15 May 2021 04:32:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Eli Zaretskii Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 15 May 2021 08:32:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 47408 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 47408-submit@debbugs.gnu.org id=B47408.162106751710802 (code B ref 47408); Sat, 15 May 2021 08:32:02 +0000 Original-Received: (at 47408) by debbugs.gnu.org; 15 May 2021 08:31:57 +0000 Original-Received: from localhost ([127.0.0.1]:47489 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lhpiH-0002oA-4f for submit@debbugs.gnu.org; Sat, 15 May 2021 04:31:57 -0400 Original-Received: from eggs.gnu.org ([209.51.188.92]:55414) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lhpiF-0002nx-7X for 47408@debbugs.gnu.org; Sat, 15 May 2021 04:31:55 -0400 Original-Received: from fencepost.gnu.org ([2001:470:142:3::e]:37966) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lhpiA-0007Si-0C; Sat, 15 May 2021 04:31:50 -0400 Original-Received: from 84.94.185.95.cable.012.net.il ([84.94.185.95]:1995 helo=home-c4e4a596f7) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lhpi8-00078g-8F; Sat, 15 May 2021 04:31:49 -0400 In-Reply-To: <70503251-f8ea-9006-b7e7-b13b93bb71de@gmail.com> (message from fabrice nicol on Wed, 12 May 2021 18:35:43 +0200) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:206574 Archived-At: > From: fabrice nicol > Date: Wed, 12 May 2021 18:35:43 +0200 > > Yes, I did post a patch with all your review comments complied with, or so I think, on March 29. > There is just one review comment of yours that I did not follow: upon closer examination, it is unnecessary > and may be misleading to specify "Mercury-specific behavior for --no-defines". See below comments in my > March 29 email. > Note that in this default case, etags support for Prolog works the same way, so there is no good reason to > make a special case for Mercury. I'm confused. First, you originally said that this option had to do something special for Mercury. Moreover, the patch you sent now still says: +** 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'. So there still is some Mercury-specific behavior here. What am I missing? > > Patch is file 0001-Add... .patch, joined again. > > I hope this works. > Best, > Fabrice > > Le mer. 12 mai 2021 à 5:47 PM, Eli Zaretskii a écrit : > > From: fabrice nicol > > Date: Wed, 12 May 2021 17:16:56 +0200 > > > > All papers have been signed and approved by copyright clerks. > > > > Do I have anything to do now, like issue a pull request in the git repository? Or just sit back and wait for the > > procedure to unroll? > > An updated patch with all the review comments taken care of would be > nice. I don't think we had such a patch before the paperwork started, > did we? > > -------- Message transféré -------- > > Sujet : bug#47408: Etags support for Mercury [v0.4] > Date : Mon, 29 Mar 2021 13:53:26 +0200 > De : fabrice nicol > Pour : 47408@debbugs.gnu.org > > 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 my 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 > 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. > > [2:text/x-patch Hide Save:0001-Add-etags-support-for-Mercury-v0.4.patch (139kB)] > > >From a0781212917457d3569de941c80364523a422c08 Mon Sep 17 00:00:00 2001 > From: Fabrice Nicol > 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". > > * 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; > } > > + > +/* > + * 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: > + * :-( > + * If with_mercury_definitions == true, we also add: > + * ( > + * or :- > + * 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; > +} > + > > /* > * 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("""") to > + // determine it. However constructing the 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 > >