From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: fabrice nicol Newsgroups: gmane.emacs.bugs Subject: bug#47408: Etags support for Mercury [v0.4] Date: Mon, 29 Mar 2021 13:53:26 +0200 Message-ID: References: <5ba2fec3-3f61-fb7e-35eb-7188fa6064a4@gmail.com> <834kgvo220.fsf@gnu.org> <97f573da-ec63-7362-13c2-ca28a6634480@gmail.com> <83o8f3meo8.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------AD1429F63D3329A3230DD426" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="15789"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.9.0 To: 47408@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Mon Mar 29 13:53:15 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 1lQqSI-0003u1-Im for geb-bug-gnu-emacs@m.gmane-mx.org; Mon, 29 Mar 2021 13:53:14 +0200 Original-Received: from localhost ([::1]:35638 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lQqSH-0002lt-KZ for geb-bug-gnu-emacs@m.gmane-mx.org; Mon, 29 Mar 2021 07:53:13 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:55526) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lQqS6-0002lO-6g for bug-gnu-emacs@gnu.org; Mon, 29 Mar 2021 07:53:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:36466) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lQqS5-0008Eh-V5 for bug-gnu-emacs@gnu.org; Mon, 29 Mar 2021 07:53:01 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lQqS5-0004Tj-Qi for bug-gnu-emacs@gnu.org; Mon, 29 Mar 2021 07:53:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: fabrice nicol Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Mon, 29 Mar 2021 11:53:01 +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.161701878117208 (code B ref 47408); Mon, 29 Mar 2021 11:53:01 +0000 Original-Received: (at 47408) by debbugs.gnu.org; 29 Mar 2021 11:53:01 +0000 Original-Received: from localhost ([127.0.0.1]:48013 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lQqS4-0004TU-RL for submit@debbugs.gnu.org; Mon, 29 Mar 2021 07:53:00 -0400 Original-Received: from mail-wm1-f54.google.com ([209.85.128.54]:41484) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lQqS2-0004TH-Uc for 47408@debbugs.gnu.org; Mon, 29 Mar 2021 07:52:59 -0400 Original-Received: by mail-wm1-f54.google.com with SMTP id t5-20020a1c77050000b029010e62cea9deso6535029wmi.0 for <47408@debbugs.gnu.org>; Mon, 29 Mar 2021 04:52:58 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=subject:to:references:from:message-id:date:user-agent:mime-version :in-reply-to:content-language; bh=6Flpc1tYsHhnxK0aC/tshvqw0AasDfPuRTllN0+aN0w=; b=buIWW2fPZ3za5cM+5ei/GkCVCkzqkLsmRQk9U1ky2dciNTKnlnBfn8ckGWJEP3yQ9i dHzOE7a2cY97QZ1YZBLtdMqqQrF7relPthJt/ooLhLRrQQPiHimSpYLRqD5Ll1ZoMo3V 7Mlr+ZgBFpoFdcJj9ef7S3DKNuXjK9+PrR9oqaFqKpla5YX6o/+f2vER8YORqz4Vixwt lN318qcHuDRAtv4c9+Gf+zRLgOpVDtcV0H0CN/5iTH54q0IJRtxypUUFdnpW8yiXCU0l Exv8okA4VTylD1K2k8g1A2pZNSCu5BQK6EnMYqOGaNFn7nOP7paQmVPOaD/A2G51VVfn Z7AA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:subject:to:references:from:message-id:date :user-agent:mime-version:in-reply-to:content-language; bh=6Flpc1tYsHhnxK0aC/tshvqw0AasDfPuRTllN0+aN0w=; b=mw4S0yqTIiTcp1v6UZfVxCQaMWxVSBRsm6keKUlAgDVZWZIUyLJlTcQdW25LX9L/xu SCdHH6XK5KULWJ97oMhCgWve61Y4vc881uCNc2Tjf7s72PYbdaTexWLZ85MLKIKVNk9H QjQWtJzMPBF+Dn8kf75/uoj64x11prnGdv6wpgW/ELfAE+GmAeiWHVzehrT79rJeuhmQ +oOhVb3+j4lS75sFaTkbR5jtCIQsgY9E1/t7VsyJYxM9myh6RX+qZ66UqzdrA8eZUycO T2uHmPwpV5duzFOPj24Um7/04qlgYUggNY8P6XaKUQjabQsIbtiz4URx3n34rd3a4jKg Ojmw== X-Gm-Message-State: AOAM5328ZEKfbX6dRvuvdYD4V8B8+Foly2uGihK6tsBB/abtY58Bf9dP WgS/TSkCYFc66J7qO8iuUaWlZ+9+cj4= X-Google-Smtp-Source: ABdhPJyQQQ/4htsH3nhHCUcRq921ox98n0/hAP+a6quLmIXh/Sk4gBI/mOuP+0ZS+gCnBRA6QOsK3A== X-Received: by 2002:a1c:c282:: with SMTP id s124mr24423137wmf.99.1617018772939; Mon, 29 Mar 2021 04:52:52 -0700 (PDT) Original-Received: from ?IPv6:2a01:cb1d:88b9:5c00:7b73:7901:965e:8523? ([2a01:cb1d:88b9:5c00:7b73:7901:965e:8523]) by smtp.gmail.com with ESMTPSA id o5sm23028448wrx.60.2021.03.29.04.52.51 for <47408@debbugs.gnu.org> (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Mon, 29 Mar 2021 04:52:51 -0700 (PDT) In-Reply-To: <83o8f3meo8.fsf@gnu.org> Content-Language: en-US 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:203233 Archived-At: This is a multi-part message in MIME format. --------------AD1429F63D3329A3230DD426 Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 8bit Attached is the new patch that integrates your indications. Please note two points: 1. Now that -m/-M have been done with, there is no use specifying any Mercury-specific behavior for --no-defines. Actually the Mercury community consensus is that all declarations should be tagged in any case. So --no-defines is just the default behavior of etags run without any option and does not need to be used explicitly or specifically documented. I followed your indications about --declarations. I also added a line to etags.1 about --language=mercury or --language=objc, should the heuristic test fail to detect the right language. Note, however, that removing language-specific options comes at a price. The heuristic test has now to be more complex. I had errless detection results against my test base of 4,000 mercury files and 500 Obj.-C files. This looks satisfactory but I had to tweak the heuristic test function (test_objc_is_mercury) quite a bit to weed out detection failures. I added the ChangeLog, the requested test file (array.m) under test/manual/etags/merc-src and altered the corresponding Makefile accordingly. 2. I removed by added line to speedbar.el, which in the end did not prove very useful. It is located in a Xemacs compatibility layer that is no longer used by most users. Le 28/03/2021 à 18:22, Eli Zaretskii a écrit : >> From: fabrice nicol >> 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. --------------AD1429F63D3329A3230DD426 Content-Type: text/x-patch; charset=UTF-8; name="0001-Add-etags-support-for-Mercury-v0.4.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="0001-Add-etags-support-for-Mercury-v0.4.patch" >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 --------------AD1429F63D3329A3230DD426--