* bug#47408: Emacs etags support for Mercury [v0.2] [not found] <25b8baef-11f2-7079-69d8-3207a24658fc@gmail.com> @ 2021-03-26 7:09 ` fabrice nicol 2021-03-27 10:51 ` bug#47408: Etags support for Mercury [v0.3] fabrice nicol 0 siblings, 1 reply; 27+ messages in thread From: fabrice nicol @ 2021-03-26 7:09 UTC (permalink / raw) To: 47408 [-- Attachment #1: Type: text/plain, Size: 4770 bytes --] Hi, As a follow-up to my previous threads on the Emacs devel list (see below), I am now submitting a revised patch that takes into account suggestions from two devel-list members (and adds in support for declarations with variable quantifiers over predicates and functions). I also consulted members from the Mercury devel list (reviews-request@lists.mercurylang.org). Although they did not go into the 'etags' code, as they mostly use Vim, the overall design does seem to meet approval there. The patch proposes adding two options to 'etags', namely -M/--declarations and -m/--no-defines. As explained in my prior threads, this is justified by the fact that Mercury is derived from Prolog. It is not unusual to have to port Prolog code into Mercury. Yet Emacs 'etags' Prolog support is quite different, as Prolog has no types or declarations, so predicates appearing first in clauses are tagged as a workaround in Prolog 'etags' support. Unlike Prolog, Mercury has declarations, which should be tagged in priority (this is the community consensus). But preserving some sort of backward compatibility with Prolog may be quite useful for porting purposes, notably. There is no clean way to achieve this without adding at least one extra option to 'etags' (with an argument), or two options without argument, which I personally find clearer. Regarding tests, the following link to source code from the Mercury compiler has (almost) all the possible use cases: https://raw.githubusercontent.com/Mercury-Language/mercury/master/library/array.m Thanks in advance for considering this submission. Fabrice Nicol Message-Id: <E1lOzjX-00GjV8-Hj@tucano.isti.cnr.it> > You will note an unconventional move. I was daring enough to add two > options to 'etags' (-m and -M) to implement some kind of backward > compatibility with Prolog etags support (based on tagging definitions, > -M) while allowing a simpler, more idiomatic approach that focuses on > tagging Mercury declarations only (-m). Backward compatibility is > legitimate and quite useful, but having it on board all the time may > be cumbersome for some use cases. Hence the 'behavioral' options I added. I fear this is too intrusive, but easy to amend. Instead of -M, you should use --declarations Instead of -m, you should use --no-defines In both cases, the description of the options should be augmented with their Mercury use. ------------------------- In-Reply-To: <b9e2c35c-ba8f-5114-031f-36f580ae994e@gmail.com> Content-Type: multipart/mixed; boundary="------------7AF01A37602B0D491A3765DF" Content-Language: en-US This is a multi-part message in MIME format. --------------7AF01A37602B0D491A3765DF Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 8bit As a follow-up to my message of March 22, I would appreciate to get some feedback on the attached patch implementing Mercury support for 'etags' before considering a formal submission. You will note an unconventional move. I was daring enough to add two options to 'etags' (-m and -M) to implement some kind of backward compatibility with Prolog etags support (based on tagging definitions, -M) while allowing a simpler, more idiomatic approach that focuses on tagging Mercury declarations only (-m). Backward compatibility is legitimate and quite useful, but having it on board all the time may be cumbersome for some use cases. Hence the 'behavioral' options I added. Fabrice Nicol ------------------------ Date: Mon, 22 Mar 2021 19:23:33 +0200 Message-Id: <83y2ef9k6i.fsf@gnu.org> From: Eli Zaretskii <eliz@gnu.org> Cc: emacs-devel@gnu.org In-Reply-To: <b9e2c35c-ba8f-5114-031f-36f580ae994e@gmail.com> (message from fabrice nicol on Mon, 22 Mar 2021 03:02:03 +0100) Subject: Re: etags support for the Mercury programming language References: <b9e2c35c-ba8f-5114-031f-36f580ae994e@gmail.com> > Date: Mon, 22 Mar 2021 03:02:03 +0100 > > I have been developing Emacs etags support for the Mercury > logic/functional programming language (https://mercurylang.org/), > based on the current code for Prolog support. > > Before proposing a patch for review, I would like to know if > (considering the limited audience) such a proposal stands a chance of > being accepted. All the changes are located in lib-src/etags.c (plus > two lines in lisp/speedbar.el). Yes, I think support for additional languages in etags is always welcome. But please also be sure to update the etags.1 man page with the relevant information, and announce the addition in NEWS. If the changes are substantial, we will need you to assign the copyright for these changes to the FSF. Would you like to start the legal paperwork rolling now? If so, I will send you the form to fill. Thanks. [-- Attachment #2: 0001-Prepare-commit-for-submission-Mercury-etags-support.patch --] [-- Type: text/x-patch, Size: 18412 bytes --] From 03c7e5cfa23196b2e3a5564be87a8bbd01730f81 Mon Sep 17 00:00:00 2001 From: Fabrice Nicol <fabrnicol@gmail.com> Date: Fri, 26 Mar 2021 06:15:43 +0100 Subject: [PATCH] Prepare commit for submission [Mercury etags support] --- doc/man/etags.1 | 25 +++- etc/NEWS | 9 ++ lib-src/etags.c | 371 +++++++++++++++++++++++++++++++++++++++++++++-- lisp/speedbar.el | 2 + 4 files changed, 394 insertions(+), 13 deletions(-) diff --git a/doc/man/etags.1 b/doc/man/etags.1 index c5c15fb182..903e38a145 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-25" "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. @@ -270,6 +270,23 @@ prints detailed information about how tags are created for LANG. .B \-V, \-\-version Print the current version of the program (same as the version of the emacs \fBetags\fP is shipped with). +.TP +.B \-, \-\-version +Print the current version of the program (same as the version of the +emacs \fBetags\fP is shipped with). +.TP +.B \-M, \-\-no\-defines +For the Mercury programming language, tag both declarations and +definitions. Declarations start a line with \fI:\-\fP optionally followed by a +quantifier over a variable (\fIsome [T]\fP or \fIall [T]\fP), then by +a builtin operator like \fIpred\fP or \fIfunc\fP. +Definitions are first rules of clauses, as in Prolog. +Implies \-\-language=mercury. +.TP +.B \-m, \-\-declarations +For the Mercury programming language, tag declarations as with \fB\-M\fP, but do not +tag definitions. Implies \-\-language=mercury. + .SH "SEE ALSO" "\|\fBemacs\fP\|" entry in \fBinfo\fP; \fIGNU Emacs Manual\fP, Richard diff --git a/etc/NEWS b/etc/NEWS index 68812c64cc..f3455b341f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -93,6 +93,15 @@ useful on systems such as FreeBSD which ships only with "etc/termcap". \f * Changes in Emacs 28.1 +--- +** Etags support for the Mercury programming language (https://mercurylang.org). +** New etags command line options '-M/-m' or --with-mercury-definitions/all'. +Tags all Mercury declarations. For compatibility with Prolog etags support, +predicates and functions appearing first in clauses will be tagged if etags is +run with the option '-M' or '--with-mercury-all'. If run with '-m' or +'--with-mercury-definitions', only declarations will be tagged. Both options +imply --language=mercury. + +++ ** 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/etags.c b/lib-src/etags.c index b5c18e0e01..9019b619d4 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -359,6 +359,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 *); @@ -502,6 +503,8 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ { "ignore-case-regex", required_argument, NULL, 'c' }, { "parse-stdin", required_argument, NULL, STDIN }, { "version", no_argument, NULL, 'V' }, + { "with-mercury-all", no_argument, NULL, 'M' }, + { "with-mercury-definitions", no_argument, NULL, 'm' }, #if CTAGS /* Ctags options */ { "backward-search", no_argument, NULL, 'B' }, @@ -621,7 +624,6 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ "In Java code, all the tags constructs of C and C++ code are\n\ tagged. (Use --help --lang=c --lang=c++ --lang=java for full help.)"; - static const char *Cobol_suffixes [] = { "COB", "cob", NULL }; static char Cobol_help [] = @@ -683,10 +685,21 @@ #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", /* Use option -l mercury to switch from Objective C to Mercury. */ + 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 --with-mercury-definitions."; +static bool with_mercury_definitions = false; + static const char *Objc_suffixes [] = - { "lm", /* Objective lex file */ - "m", /* Objective C file */ - NULL }; + {"lm", + "m", /* By default, Objective C 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\ @@ -773,7 +786,6 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ 'TEXTAGS' to a colon-separated list like, for example,\n\ TEXTAGS=\"mycommand:myothercommand\"."; - static const char *Texinfo_suffixes [] = { "texi", "texinfo", "txi", NULL }; static const char Texinfo_help [] = @@ -824,6 +836,7 @@ #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}, + { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes }, { "objc", Objc_help, plain_C_entries, Objc_suffixes }, { "pascal", Pascal_help, Pascal_functions, Pascal_suffixes }, { "perl",Perl_help,Perl_functions,Perl_suffixes,NULL,Perl_interpreters}, @@ -1061,6 +1074,17 @@ print_help (argument *argbuffer) which you like."); } + puts ("-m, --mercury-declarations\n\ + For the Mercury programming language, only tag declarations.\n\ + Declarations start a line with :- \n\ + Implies --language=mercury."); + + puts ("-M, --mercury-all\n\ + For the Mercury programming language, include both declarations and\n\ + definitions. Declarations start a line with :- while definitions\n\ + are first rules for a given item, as for Prolog.\n\ + Implies --language=mercury."); + puts ("-V, --version\n\ Print the version of the program.\n\ -h, --help\n\ @@ -1111,7 +1135,7 @@ main (int argc, char **argv) /* When the optstring begins with a '-' getopt_long does not rearrange the non-options arguments to be at the end, but leaves them alone. */ - optstring = concat ("-ac:Cf:Il:o:Qr:RSVhH", + optstring = concat ("-ac:Cf:Il:Mmo:Qr:RSVhHW", (CTAGS) ? "BxdtTuvw" : "Di:", ""); @@ -1202,6 +1226,17 @@ main (int argc, char **argv) case 'Q': class_qualify = 1; break; + case 'M': + with_mercury_definitions = true; FALLTHROUGH; + case 'm': + { + language lang = + { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes }; + + argbuffer[current_arg].lang = ⟨ + argbuffer[current_arg].arg_type = at_language; + } + break; /* Etags options */ case 'D': constantypedefs = false; break; @@ -1281,6 +1316,22 @@ main (int argc, char **argv) pfatal (tagfile); } + /* /\* Settle the Mercury/Objective C file extension issue. *\/ */ + + /* if (parsing_mercury) */ + /* { */ + /* Objc_suffixes = */ + /* { "lm", /\* Objective lex file *\/ */ + /* NULL }; /\* Remove .m from Obj_c identification. *\/ */ + /* Mercury_suffixes = {"m", NULL}; */ + /* } */ + /* else */ + /* { */ + /* Objc_suffixes = /\* Standard Objective C specification *\/ */ + /* {"lm", "m", NULL}; */ + /* Mercury_suffixes = {NULL}; */ + /* } */ + /* * Loop through files finding functions. */ @@ -2297,7 +2348,7 @@ invalidate_nodes (fdesc *badfdp, node **npp) } } -\f + static ptrdiff_t total_size_of_entries (node *); static int number_len (intmax_t) ATTRIBUTE_CONST; @@ -3222,7 +3273,7 @@ consider_token (char *str, /* IN: token pointer */ return false; } -\f + /* * C_entries often keeps pointers to tokens or lines which are older than * the line currently read. By keeping two line buffers, and switching @@ -5890,7 +5941,8 @@ Prolog_functions (FILE *inf) { if (cp[0] == '\0') /* Empty line */ continue; - else if (c_isspace (cp[0])) /* Not a predicate */ + else if (c_isspace (cp[0]) || cp[0] == '%') + /* Not a predicate or comment */ continue; else if (cp[0] == '/' && cp[1] == '*') /* comment. */ prolog_skip_comment (&lb, inf); @@ -6019,6 +6071,307 @@ prolog_atom (char *s, size_t pos) return 0; } +\f +/* + * Support for Mercury + * + * Assumes that the declarationa starts at column 0. + * Original code by Sunichirou Sugou (1989) for Prolog. + * Rewritten by Anders Lindgren (1996) for Prolog. + * Adapted by Fabrice Nicol (2021) for Mercury. + * Note: Prolog-support behavior is preserved if + * --with-mercury-definitions 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; + +static void +Mercury_functions (FILE *inf) +{ + char *cp, *last = NULL; + ptrdiff_t lastlen = 0, allocated = 0; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + if (cp[0] == '\0') /* Empty line */ + continue; + else if (c_isspace (cp[0]) || cp[0] == '%') + /* a Prolog-type comment or anything other than a declaration */ + continue; + else if (cp[0] == '/' && cp[1] == '*') /* Mercury C-type comment. */ + mercury_skip_comment (&lb, inf); + else + { + is_mercury_declaration = (cp[0] == ':' && cp[1] == '-'); + + if (is_mercury_declaration + || with_mercury_definitions) + { + ptrdiff_t len = mercury_pr (cp, last, lastlen); + if (0 < len) + { + /* Store the declaration to avoid generating duplicate + tags later. */ + if (allocated <= len) + { + xrnew (last, len + 1, 1); + allocated = len + 1; + } + memcpyz (last, cp, len); + lastlen = len; + } + } + } + } + free (last); +} + +static void +mercury_skip_comment (linebuffer *plb, FILE *inf) +{ + char *cp; + + do + { + for (cp = plb->buffer; *cp != '\0'; ++cp) + if (cp[0] == '*' && cp[1] == '/') + return; + readline (plb, inf); + } + while (perhaps_more_input (inf)); +} + +/* + * A declaration is added if it matches: + * <beginning of line>:-<whitespace><Mercury Term><whitespace>( + * If with_mercury_definitions == true, we also add: + * <beginning of line><Mercury item><whitespace>( + * or <beginning of line><Mercury item><whitespace>:- + * As for Prolog support, different arities and types are not taken into + * consideration. + * Item is added to the tags database if it doesn't match the + * name of the previous declaration. + * + * Consume a Mercury declaration. + * Return the number of bytes consumed, or 0 if there was an error. + * + * A Mercury declaration must be one of: + * :- type + * :- solver type + * :- pred + * :- func + * :- inst + * :- mode + * :- typeclass + * :- instance + * :- pragma + * :- promise + * :- initialise + * :- finalise + * :- mutable + * :- module + * :- interface + * :- implementation + * :- import_module + * :- use_module + * :- include_module + * :- end_module + * followed on the same line by an alphanumeric sequence, starting with a lower + * case letter or by a single-quoted arbitrary string. + * Single quotes can escape themselves. Backslash quotes everything. + * + * Return the size of the name of the declaration or 0 if no header was found. + * As quantifiers may precede functions or predicates, we must list them too. + */ + +static const char *Mercury_decl_tags[] = {"type", "solver type", "pred", + "func", "inst", "mode", "typeclass", "instance", "pragma", "promise", + "initialise", "finalise", "mutable", "module", "interface", "implementation", + "import_module", "use_module", "include_module", "end_module", "some", "all"}; + +static size_t +mercury_decl (char *s, size_t pos) +{ + if (s == NULL) return 0; + + size_t origpos; + origpos = pos; + + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) ++pos; + + uint8_t decl_type_length = pos - origpos; + char buf[decl_type_length + 1]; + memset(buf, 0, decl_type_length + 1); + + /* Mercury declaration tags. Consume them, then check the declaration item + following :- is legitimate, then go on as in the prolog case. */ + + memcpy(buf, &s[origpos], decl_type_length); + + bool found_decl_tag = false; + + if (is_mercury_quantifier) + { + if (strcmp(buf, "pred") != 0 && strcmp(buf, "func") != 0) /* Bad syntax */ + return 0; + is_mercury_quantifier = false; /* Beset to base value. */ + found_decl_tag = true; + } + else + { + for (int j = 0; j < sizeof(Mercury_decl_tags)/sizeof(char*); ++j) + { + if (strcmp(buf, Mercury_decl_tags[j]) == 0) + { + found_decl_tag = true; + if (strcmp(buf, "type") == 0) + is_mercury_type = true; + + if (strcmp(buf, "some") == 0 + || strcmp(buf, "all") == 0) { + is_mercury_quantifier = true; + } + + break; /* Found declaration tag of rank j. */ + } + else + /* 'solver type' has a blank in the middle, + so this is the hard case */ + if (strcmp(buf, "solver") == 0) + { + ++pos; + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) + ++pos; + + decl_type_length = pos - origpos; + char buf2[decl_type_length + 1]; + memset(buf2, 0, decl_type_length + 1); + memcpy(buf2, &s[origpos], decl_type_length); + + if (strcmp(buf2, "solver type") == 0) + { + found_decl_tag = false; + break; /* Found declaration tag of rank j. */ + } + } + } + } + + /* If with_mercury_definitions == false + * this is a Mercury syntax error, ignoring... */ + + if (with_mercury_definitions) + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again */ + else + /* Prolog-like behavior + * we have parsed the predicate once, yet inappropriately + * so restarting again the parsing step */ + pos = 0; + } + else + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again */ + else + return 0; + } + + /* From now on it is the same as for Prolog except for module dots */ + + if (c_islower (s[pos]) || s[pos] == '_' ) + { + /* The name is unquoted. + Do not confuse module dots with end-of-declaration dots. */ + + while (c_isalnum (s[pos]) + || s[pos] == '_' + || (s[pos] == '.' /* A module dot */ + && s + pos + 1 != NULL + && (c_isalnum (s[pos + 1]) || s[pos + 1] == '_'))) + ++pos; + + return pos - origpos; + } + else if (s[pos] == '\'') + { + ++pos; + for (;;) + { + if (s[pos] == '\'') + { + ++pos; + if (s[pos] != '\'') + break; + ++pos; /* A double quote */ + } + else if (s[pos] == '\0') /* Multiline quoted atoms are ignored. */ + return 0; + else if (s[pos] == '\\') + { + if (s[pos+1] == '\0') + return 0; + pos += 2; + } + else + ++pos; + } + return pos - origpos; + } + else if (is_mercury_quantifier && s[pos] == '[') /* :- some [T] pred/func */ + { + for (++pos; s + pos != NULL && s[pos] != ']'; ++pos) {} + if (s + pos == NULL) return 0; + ++pos; + pos = skip_spaces (s + pos) - s; + return mercury_decl(s, pos) + pos - origpos; + } + else + return 0; +} + +static ptrdiff_t +mercury_pr (char *s, char *last, ptrdiff_t lastlen) +{ + size_t len0 = 0; + is_mercury_type = false; + is_mercury_quantifier = false; + + if (is_mercury_declaration) + { + /* Skip len0 blanks only for declarations. */ + len0 = skip_spaces (s + 2) - s; + } + + size_t len = mercury_decl (s , len0); + if (len == 0) return 0; + len += len0; + + if (( (s[len] == '.' /* This is a statement dot, not a module dot. */ + || (s[len] == '(' && (len += 1)) + || (s[len] == ':' /* Stopping in case of a rule. */ + && s[len + 1] == '-' + && (len += 2))) + && (lastlen != len || memcmp (s, last, len) != 0) + ) + /* Types are often declared on several lines so keeping just + the first line */ + || is_mercury_type + ) + { + make_tag (s, 0, true, s, len, lineno, linecharno); + return len; + } + + return 0; +} + \f /* * Support for Erlang diff --git a/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) -- 2.26.3 ^ permalink raw reply related [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.3] 2021-03-26 7:09 ` bug#47408: Emacs etags support for Mercury [v0.2] fabrice nicol @ 2021-03-27 10:51 ` fabrice nicol 2021-03-28 13:11 ` Eli Zaretskii 0 siblings, 1 reply; 27+ messages in thread From: fabrice nicol @ 2021-03-27 10:51 UTC (permalink / raw) To: 47408 [-- Attachment #1: Type: text/plain, Size: 445 bytes --] Hi, I'm sending a new patch for this Mercury feature request. The attached patch fixes a previously unnoticed regression that affects Objective C parsing (Mercury and Objective C have same file extensions .m). I had to resort to an added heuristics (implemented in `test_objc_is_mercury') to disambiguate Mercury from Objective C source files with extension .m. The patch is cumulative and replaces the former one. Best, Fabrice Nicol [-- Attachment #2: 0001-Fixed-regressions-caused-by-Objc-Mercury-ambiguous-f.patch --] [-- Type: text/x-patch, Size: 20603 bytes --] From 50f3f9a0d46d11d0ac096f79f0d5aa1bc17b7920 Mon Sep 17 00:00:00 2001 From: Fabrice Nicol <fabrnicol@gmail.com> Date: Sat, 27 Mar 2021 10:16:44 +0100 Subject: [PATCH] Fixed regressions caused by Objc/Mercury ambiguous file extension .m. --- doc/man/etags.1 | 25 ++- etc/NEWS | 9 + lib-src/etags.c | 444 ++++++++++++++++++++++++++++++++++++++++++++--- lisp/speedbar.el | 2 + 4 files changed, 455 insertions(+), 25 deletions(-) diff --git a/doc/man/etags.1 b/doc/man/etags.1 index c5c15fb182..903e38a145 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-25" "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. @@ -270,6 +270,23 @@ prints detailed information about how tags are created for LANG. .B \-V, \-\-version Print the current version of the program (same as the version of the emacs \fBetags\fP is shipped with). +.TP +.B \-, \-\-version +Print the current version of the program (same as the version of the +emacs \fBetags\fP is shipped with). +.TP +.B \-M, \-\-no\-defines +For the Mercury programming language, tag both declarations and +definitions. Declarations start a line with \fI:\-\fP optionally followed by a +quantifier over a variable (\fIsome [T]\fP or \fIall [T]\fP), then by +a builtin operator like \fIpred\fP or \fIfunc\fP. +Definitions are first rules of clauses, as in Prolog. +Implies \-\-language=mercury. +.TP +.B \-m, \-\-declarations +For the Mercury programming language, tag declarations as with \fB\-M\fP, but do not +tag definitions. Implies \-\-language=mercury. + .SH "SEE ALSO" "\|\fBemacs\fP\|" entry in \fBinfo\fP; \fIGNU Emacs Manual\fP, Richard diff --git a/etc/NEWS b/etc/NEWS index 68812c64cc..4af4e76371 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -93,6 +93,15 @@ useful on systems such as FreeBSD which ships only with "etc/termcap". \f * Changes in Emacs 28.1 +--- +** Etags support for the Mercury programming language (https://mercurylang.org). +** New etags command line options '-M/-m' or --declarations/--no-defines'. +Tags all Mercury declarations. For compatibility with Prolog etags support, +predicates and functions appearing first in clauses will be tagged if etags is +run with the option '-M' or '--declarations'. If run with '-m' or +'--no-defines', declarations will be tagged but definitions will not. +Both options imply --language=mercury. + +++ ** 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/etags.c b/lib-src/etags.c index b5c18e0e01..53e04794dd 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -142,7 +142,13 @@ 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 */ +#ifndef MERCURY_HEURISTICS_RATIO +# define MERCURY_HEURISTICS_RATIO 0.02 +#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 +365,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 +385,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); @@ -621,7 +629,6 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ "In Java code, all the tags constructs of C and C++ code are\n\ tagged. (Use --help --lang=c --lang=c++ --lang=java for full help.)"; - static const char *Cobol_suffixes [] = { "COB", "cob", NULL }; static char Cobol_help [] = @@ -683,10 +690,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", /* Use option -l mercury to switch from Objective C to Mercury. */ + 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 -M or --declarations."; +static bool with_mercury_definitions = false; +double mercury_heuristics_ratio = MERCURY_HEURISTICS_RATIO; + static const char *Objc_suffixes [] = - { "lm", /* Objective lex file */ - "m", /* Objective C file */ - NULL }; + {"lm", + "m", /* By default, Objective C 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\ @@ -773,7 +792,6 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ 'TEXTAGS' to a colon-separated list like, for example,\n\ TEXTAGS=\"mycommand:myothercommand\"."; - static const char *Texinfo_suffixes [] = { "texi", "texinfo", "txi", NULL }; static const char Texinfo_help [] = @@ -824,7 +842,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 }, @@ -1061,6 +1081,17 @@ print_help (argument *argbuffer) which you like."); } + puts ("-m, --declarations\n\ + For the Mercury programming language, only tag declarations.\n\ + Declarations start a line with :- \n\ + Implies --language=mercury."); + + puts ("-M, --no-defines\n\ + For the Mercury programming language, include both declarations and\n\ + definitions. Declarations start a line with :- while definitions\n\ + are first rules for a given item, as for Prolog.\n\ + Implies --language=mercury."); + puts ("-V, --version\n\ Print the version of the program.\n\ -h, --help\n\ @@ -1111,7 +1142,7 @@ main (int argc, char **argv) /* When the optstring begins with a '-' getopt_long does not rearrange the non-options arguments to be at the end, but leaves them alone. */ - optstring = concat ("-ac:Cf:Il:o:Qr:RSVhH", + optstring = concat ("-ac:Cf:Il:Mmo:Qr:RSVhHW", (CTAGS) ? "BxdtTuvw" : "Di:", ""); @@ -1202,9 +1233,20 @@ main (int argc, char **argv) case 'Q': class_qualify = 1; break; + case 'M': + with_mercury_definitions = true; FALLTHROUGH; + case 'm': + { + language lang = + { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes }; + + argbuffer[current_arg].lang = ⟨ + argbuffer[current_arg].arg_type = at_language; + } + break; /* Etags options */ - case 'D': constantypedefs = false; break; + case 'D': constantypedefs = false; break; case 'i': included_files[nincluded_files++] = optarg; break; /* Ctags options. */ @@ -1298,19 +1340,19 @@ main (int argc, char **argv) analyze_regex (argbuffer[i].what); break; case at_filename: - this_file = argbuffer[i].what; - /* Input file named "-" means read file names from stdin - (one per line) and use them. */ - if (streq (this_file, "-")) - { - if (parsing_stdin) - fatal ("cannot parse standard input " - "AND read file names from it"); - while (readline_internal (&filename_lb, stdin, "-") > 0) - process_file_name (filename_lb.buffer, lang); - } - else - process_file_name (this_file, lang); + this_file = argbuffer[i].what; + /* Input file named "-" means read file names from stdin + (one per line) and use them. */ + if (streq (this_file, "-")) + { + if (parsing_stdin) + fatal ("cannot parse standard input " + "AND read file names from it"); + while (readline_internal (&filename_lb, stdin, "-") > 0) + process_file_name (filename_lb.buffer, lang); + } + else + process_file_name (this_file, lang); break; case at_stdin: this_file = argbuffer[i].what; @@ -1775,6 +1817,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 +6066,361 @@ prolog_atom (char *s, size_t pos) return 0; } +\f +/* + * Support for Mercury + * + * Assumes that the declarationa starts at column 0. + * Original code by Sunichirou Sugou (1989) for Prolog. + * Rewritten by Anders Lindgren (1996) for Prolog. + * Adapted by Fabrice Nicol (2021) for Mercury. + * Note: Prolog-support behavior is preserved if + * -M/--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; + +/* To robustly disambiguate between Objective C and Mercury, parse file + with the following heuristics hook: + (number of occurrences of non-blank, non-fully-commented lines + comprising ':-' at the start of line)/ number of lines > mercury_heuristics_ratio */ + +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) return; + int c; + uint64_t lines = 1; + uint64_t mercury_decls = 0; + bool blank_line = false; + bool start_of_line = true; + + while ((c = fgetc(fp)) != EOF) + { + switch (c) + { + case '\n': + if (! blank_line) ++lines; + blank_line = true; + start_of_line = true; + break; + case '%': FALLTHROUGH; + case ' ': FALLTHROUGH; + case '\t': + start_of_line = false; + break; + case ':': + if (! start_of_line) break; + start_of_line = false; + c = fgetc(fp); + if (c == '-') ++mercury_decls; + break; + default: + start_of_line = false; + blank_line = false; + } + } + + double ratio = 0; + ratio = ((double) mercury_decls ) / lines; + if (ratio > mercury_heuristics_ratio) + { + /* Change the language from Objective C to Mercury */ + static language lang0 = { "mercury", Mercury_help, Mercury_functions, + Mercury_suffixes }; + *lang = &lang0; + } +} + +static void +Mercury_functions (FILE *inf) +{ + char *cp, *last = NULL; + ptrdiff_t lastlen = 0, allocated = 0; + if (declarations) with_mercury_definitions = true; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + if (cp[0] == '\0') /* Empty line */ + continue; + else if (c_isspace (cp[0]) || cp[0] == '%') + /* a Prolog-type comment or anything other than a declaration */ + continue; + else if (cp[0] == '/' && cp[1] == '*') /* Mercury C-type comment. */ + mercury_skip_comment (&lb, inf); + else + { + is_mercury_declaration = (cp[0] == ':' && cp[1] == '-'); + + if (is_mercury_declaration + || with_mercury_definitions) + { + ptrdiff_t len = mercury_pr (cp, last, lastlen); + if (0 < len) + { + /* Store the declaration to avoid generating duplicate + tags later. */ + if (allocated <= len) + { + xrnew (last, len + 1, 1); + allocated = len + 1; + } + memcpyz (last, cp, len); + lastlen = len; + } + } + } + } + free (last); +} + +static void +mercury_skip_comment (linebuffer *plb, FILE *inf) +{ + char *cp; + + do + { + for (cp = plb->buffer; *cp != '\0'; ++cp) + if (cp[0] == '*' && cp[1] == '/') + return; + readline (plb, inf); + } + while (perhaps_more_input (inf)); +} + +/* + * A declaration is added if it matches: + * <beginning of line>:-<whitespace><Mercury Term><whitespace>( + * If with_mercury_definitions == true, we also add: + * <beginning of line><Mercury item><whitespace>( + * or <beginning of line><Mercury item><whitespace>:- + * As for Prolog support, different arities and types are not taken into + * consideration. + * Item is added to the tags database if it doesn't match the + * name of the previous declaration. + * + * Consume a Mercury declaration. + * Return the number of bytes consumed, or 0 if there was an error. + * + * A Mercury declaration must be one of: + * :- type + * :- solver type + * :- pred + * :- func + * :- inst + * :- mode + * :- typeclass + * :- instance + * :- pragma + * :- promise + * :- initialise + * :- finalise + * :- mutable + * :- module + * :- interface + * :- implementation + * :- import_module + * :- use_module + * :- include_module + * :- end_module + * followed on the same line by an alphanumeric sequence, starting with a lower + * case letter or by a single-quoted arbitrary string. + * Single quotes can escape themselves. Backslash quotes everything. + * + * Return the size of the name of the declaration or 0 if no header was found. + * As quantifiers may precede functions or predicates, we must list them too. + */ + +static const char *Mercury_decl_tags[] = {"type", "solver type", "pred", + "func", "inst", "mode", "typeclass", "instance", "pragma", "promise", + "initialise", "finalise", "mutable", "module", "interface", "implementation", + "import_module", "use_module", "include_module", "end_module", "some", "all"}; + +static size_t +mercury_decl (char *s, size_t pos) +{ + if (s == NULL) return 0; + + size_t origpos; + origpos = pos; + + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) ++pos; + + uint8_t decl_type_length = pos - origpos; + char buf[decl_type_length + 1]; + memset(buf, 0, decl_type_length + 1); + + /* Mercury declaration tags. Consume them, then check the declaration item + following :- is legitimate, then go on as in the prolog case. */ + + memcpy(buf, &s[origpos], decl_type_length); + + bool found_decl_tag = false; + + if (is_mercury_quantifier) + { + if (strcmp(buf, "pred") != 0 && strcmp(buf, "func") != 0) /* Bad syntax */ + return 0; + is_mercury_quantifier = false; /* Beset to base value. */ + found_decl_tag = true; + } + else + { + for (int j = 0; j < sizeof(Mercury_decl_tags)/sizeof(char*); ++j) + { + if (strcmp(buf, Mercury_decl_tags[j]) == 0) + { + found_decl_tag = true; + if (strcmp(buf, "type") == 0) + is_mercury_type = true; + + if (strcmp(buf, "some") == 0 + || strcmp(buf, "all") == 0) { + is_mercury_quantifier = true; + } + + break; /* Found declaration tag of rank j. */ + } + else + /* 'solver type' has a blank in the middle, + so this is the hard case */ + if (strcmp(buf, "solver") == 0) + { + ++pos; + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) + ++pos; + + decl_type_length = pos - origpos; + char buf2[decl_type_length + 1]; + memset(buf2, 0, decl_type_length + 1); + memcpy(buf2, &s[origpos], decl_type_length); + + if (strcmp(buf2, "solver type") == 0) + { + found_decl_tag = false; + break; /* Found declaration tag of rank j. */ + } + } + } + } + + /* If with_mercury_definitions == false + * this is a Mercury syntax error, ignoring... */ + + if (with_mercury_definitions) + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again */ + else + /* Prolog-like behavior + * we have parsed the predicate once, yet inappropriately + * so restarting again the parsing step */ + pos = 0; + } + else + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again */ + else + return 0; + } + + /* From now on it is the same as for Prolog except for module dots */ + + if (c_islower (s[pos]) || s[pos] == '_' ) + { + /* The name is unquoted. + Do not confuse module dots with end-of-declaration dots. */ + + while (c_isalnum (s[pos]) + || s[pos] == '_' + || (s[pos] == '.' /* A module dot */ + && s + pos + 1 != NULL + && (c_isalnum (s[pos + 1]) || s[pos + 1] == '_'))) + ++pos; + + return pos - origpos; + } + else if (s[pos] == '\'') + { + ++pos; + for (;;) + { + if (s[pos] == '\'') + { + ++pos; + if (s[pos] != '\'') + break; + ++pos; /* A double quote */ + } + else if (s[pos] == '\0') /* Multiline quoted atoms are ignored. */ + return 0; + else if (s[pos] == '\\') + { + if (s[pos+1] == '\0') + return 0; + pos += 2; + } + else + ++pos; + } + return pos - origpos; + } + else if (is_mercury_quantifier && s[pos] == '[') /* :- some [T] pred/func */ + { + for (++pos; s + pos != NULL && s[pos] != ']'; ++pos) {} + if (s + pos == NULL) return 0; + ++pos; + pos = skip_spaces (s + pos) - s; + return mercury_decl(s, pos) + pos - origpos; + } + else + return 0; +} + +static ptrdiff_t +mercury_pr (char *s, char *last, ptrdiff_t lastlen) +{ + size_t len0 = 0; + is_mercury_type = false; + is_mercury_quantifier = false; + + if (is_mercury_declaration) + { + /* Skip len0 blanks only for declarations. */ + len0 = skip_spaces (s + 2) - s; + } + + size_t len = mercury_decl (s , len0); + if (len == 0) return 0; + len += len0; + + if (( (s[len] == '.' /* This is a statement dot, not a module dot. */ + || (s[len] == '(' && (len += 1)) + || (s[len] == ':' /* Stopping in case of a rule. */ + && s[len + 1] == '-' + && (len += 2))) + && (lastlen != len || memcmp (s, last, len) != 0) + ) + /* Types are often declared on several lines so keeping just + the first line */ + || is_mercury_type + ) + { + make_tag (s, 0, true, s, len, lineno, linecharno); + return len; + } + + return 0; +} + \f /* * Support for Erlang diff --git a/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) -- 2.26.3 ^ permalink raw reply related [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.3] 2021-03-27 10:51 ` bug#47408: Etags support for Mercury [v0.3] fabrice nicol @ 2021-03-28 13:11 ` Eli Zaretskii 2021-03-28 15:49 ` fabrice nicol 0 siblings, 1 reply; 27+ messages in thread From: Eli Zaretskii @ 2021-03-28 13:11 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 > From: fabrice nicol <fabrnicol@gmail.com> > Date: Sat, 27 Mar 2021 11:51:22 +0100 > > I'm sending a new patch for this Mercury feature request. Thanks, I have some comments below. > >From 50f3f9a0d46d11d0ac096f79f0d5aa1bc17b7920 Mon Sep 17 00:00:00 2001 > From: Fabrice Nicol <fabrnicol@gmail.com> > Date: Sat, 27 Mar 2021 10:16:44 +0100 > Subject: [PATCH] Fixed regressions caused by Objc/Mercury ambiguous file > extension .m. Please accompany the changeset with a ChangeLog-style commit log message, you can see the style we are using via "git log" and also find some instructions in CONTRIBUTE. > .B \-V, \-\-version > Print the current version of the program (same as the version of the > emacs \fBetags\fP is shipped with). > +.TP > +.B \-, \-\-version > +Print the current version of the program (same as the version of the > +emacs \fBetags\fP is shipped with). Copy/paste mistake? or why are you duplicating the --version description? > +.TP > +.B \-M, \-\-no\-defines > +For the Mercury programming language, tag both declarations and > +definitions. Declarations start a line with \fI:\-\fP optionally followed by a > +quantifier over a variable (\fIsome [T]\fP or \fIall [T]\fP), then by > +a builtin operator like \fIpred\fP or \fIfunc\fP. > +Definitions are first rules of clauses, as in Prolog. > +Implies \-\-language=mercury. > +.TP > +.B \-m, \-\-declarations > +For the Mercury programming language, tag declarations as with \fB\-M\fP, but do not > +tag definitions. Implies \-\-language=mercury. This is not what Francesco Potortì suggested to do. He suggested that you use the existing options --no-defines and --declarations, but give them Mercury-specific meanings when processing Mercury source files. IOW, let's not introduce the new -m and -M shorthands for these options, and let's describe the Mercury-specific meaning of the existing options where they are currently described in etags.1. OK? > --- a/etc/NEWS > +++ b/etc/NEWS > @@ -93,6 +93,15 @@ useful on systems such as FreeBSD which ships only with "etc/termcap". > \f > * Changes in Emacs 28.1 > > +--- ^^^ This should be "+++", since you submitted the changes for the documentation as part of the changeset. > +** Etags support for the Mercury programming language (https://mercurylang.org). > +** New etags command line options '-M/-m' or --declarations/--no-defines'. > +Tags all Mercury declarations. For compatibility with Prolog etags support, > +predicates and functions appearing first in clauses will be tagged if etags is > +run with the option '-M' or '--declarations'. If run with '-m' or > +'--no-defines', declarations will be tagged but definitions will not. > +Both options imply --language=mercury. This should be amended for the changes in the options I described above. > +/* Define MERCURY_HEURISTICS_RATIO as it was necessary to disambiguate > + Mercury from Objective C, which have same file extensions .m */ This comment should explain how the value is used to disambiguate, so that people could decide what alternative value to use. > +static void test_objc_is_mercury(char *, language **); ^^ Our style is to leave one space between the function's name and the opening parenthesis. Please follow that here and elsewhere in your patch. > @@ -621,7 +629,6 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ > "In Java code, all the tags constructs of C and C++ code are\n\ > tagged. (Use --help --lang=c --lang=c++ --lang=java for full help.)"; > > - > static const char *Cobol_suffixes [] = > { "COB", "cob", NULL }; > static char Cobol_help [] = Why remove this empty line? > static const char *Objc_suffixes [] = > - { "lm", /* Objective lex file */ > - "m", /* Objective C file */ > - NULL }; > + {"lm", > + "m", /* By default, Objective C will be assumed. */ > + NULL}; This loses the explanation that a .lm file is an ObjC lex file. > @@ -773,7 +792,6 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ > 'TEXTAGS' to a colon-separated list like, for example,\n\ > TEXTAGS=\"mycommand:myothercommand\"."; > > - > static const char *Texinfo_suffixes [] = > { "texi", "texinfo", "txi", NULL }; > static const char Texinfo_help [] = Again, an empty line removed -- why? > + puts ("-m, --declarations\n\ > + For the Mercury programming language, only tag declarations.\n\ > + Declarations start a line with :- \n\ > + Implies --language=mercury."); > + > + puts ("-M, --no-defines\n\ > + For the Mercury programming language, include both declarations and\n\ > + definitions. Declarations start a line with :- while definitions\n\ > + are first rules for a given item, as for Prolog.\n\ > + Implies --language=mercury."); > + This should be merged with the existing description of the long options. > /* When the optstring begins with a '-' getopt_long does not rearrange the > non-options arguments to be at the end, but leaves them alone. */ > - optstring = concat ("-ac:Cf:Il:o:Qr:RSVhH", > + optstring = concat ("-ac:Cf:Il:Mmo:Qr:RSVhHW", > (CTAGS) ? "BxdtTuvw" : "Di:", > ""); As mentioned, let's not introduce -m and -M. > + case 'M': > + with_mercury_definitions = true; FALLTHROUGH; > + case 'm': > + { > + language lang = > + { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes }; > + > + argbuffer[current_arg].lang = ⟨ > + argbuffer[current_arg].arg_type = at_language; > + } > + break; Shouldn't be needed anymore. > /* Etags options */ > - case 'D': constantypedefs = false; break; > + case 'D': constantypedefs = false; break; This whitespace change is for the worse: our conventions are to use mixed spaces-with-tabs style for indentation in C source files, not just spaces. > +static void test_objc_is_mercury(char *this_file, language **lang) Our style is to write function definitions like this: static void test_objc_is_mercury (char *this_file, language **lang) IOW, break the line between the return type and the function's name. > + FILE* fp = fopen(this_file, "r"); > + if (fp == NULL) return; No error/warning if the file couldn't be open? In any case, this leaks a FILE object: you open a file, but never close it. > + uint64_t lines = 1; > + uint64_t mercury_decls = 0; We don't use such types elsewhere in etags.c; why do you need them here? can you use intmax_t instead, as we do elsewhere? > + case '%': FALLTHROUGH; > + case ' ': FALLTHROUGH; > + case '\t': > + start_of_line = false; FALLTHROUGH isn't needed here, as there's no code under the first 2 'case' lines. > + /* Change the language from Objective C to Mercury */ Our style for comments is to end each comment with a period and 2 spaces, like this: /* Change the language from Objective C to Mercury. */ Please follow this style, here and elsewhere in the changeset. > + uint8_t decl_type_length = pos - origpos; Please use 'unsigned char' instead of uint8_t. > + 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 > + ) Please avoid parentheses alone on their lines. > 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? Last, but not least: if you can, please provide a test file for the etags test suite, see test/manual/etags/. Thanks again for working on this. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.3] 2021-03-28 13:11 ` Eli Zaretskii @ 2021-03-28 15:49 ` fabrice nicol 2021-03-28 16:22 ` Eli Zaretskii 0 siblings, 1 reply; 27+ messages in thread From: fabrice nicol @ 2021-03-28 15:49 UTC (permalink / raw) To: 47408 [-- Attachment #1: Type: text/plain, Size: 6495 bytes --] Thanks for this review. Changes will be implemented soon as indicated. (1) There is just one point that I would like to discuss before changing things around: the proposed -m/-M short option issue. 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). Whether this is less intrusive (or more) than -m/-M is not crystal-clear to me. Both solutions look on a par wrt this criterion, but -m/-M may be more user-friendly. If two short options are one too many, I propose redesigning the short option pair as just one -m option with a binary argument (like: '-m defines / -m all', or -m 0 / -m 1). 2. The social side of things As indicated previously, I also consulted the Mercury review list, and the feedback was positive on -m/-M (see below): > Accommodating different people's different preferences is a good idea > if it can be done at acceptable cost. > >> Instead of -M, you should use --declarations >> >> Instead of -m, you should use --no-defines > There is no need for "instead"; you can support both forms of both options. > So I opted for a compromise: renaming long options, following F. Potorti, and keeping -m/-M, following Z. Somogyi. (2) Your following question: > 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. >> +.TP >> +.B \-M, \-\-no\-defines >> +For the Mercury programming language, tag both declarations and >> +definitions. Declarations start a line with \fI:\-\fP optionally followed by a >> +quantifier over a variable (\fIsome [T]\fP or \fIall [T]\fP), then by >> +a builtin operator like \fIpred\fP or \fIfunc\fP. >> +Definitions are first rules of clauses, as in Prolog. >> +Implies \-\-language=mercury. >> +.TP >> +.B \-m, \-\-declarations >> +For the Mercury programming language, tag declarations as with \fB\-M\fP, but do not >> +tag definitions. Implies \-\-language=mercury. > This is not what Francesco Potortì suggested to do. He suggested that > you use the existing options --no-defines and --declarations, but give > them Mercury-specific meanings when processing Mercury source files. > IOW, let's not introduce the new -m and -M shorthands for these options, > and let's describe the Mercury-specific meaning of the existing > options where they are currently described in etags.1. OK? > +** Etags support for the Mercury programming language (https://mercurylang.org). > +** New etags command line options '-M/-m' or --declarations/--no-defines'. > +Tags all Mercury declarations. For compatibility with Prolog etags support, > +predicates and functions appearing first in clauses will be tagged if etags is > +run with the option '-M' or '--declarations'. If run with '-m' or > +'--no-defines', declarations will be tagged but definitions will not. > +Both options imply --language=mercury. > This should be amended for the changes in the options I described > above. > As mentioned, let's not introduce -m and -M. > >> + case 'M': >> + with_mercury_definitions = true; FALLTHROUGH; >> + case 'm': >> + { >> + language lang = >> + { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes }; >> + >> + argbuffer[current_arg].lang = ⟨ >> + argbuffer[current_arg].arg_type = at_language; >> + } >> + break; > Shouldn't be needed anymore. > >> 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? > > Last, but not least: if you can, please provide a test file for the > etags test suite, see test/manual/etags/. > > Thanks again for working on this. [-- Attachment #2: Type: text/html, Size: 9323 bytes --] ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.3] 2021-03-28 15:49 ` fabrice nicol @ 2021-03-28 16:22 ` Eli Zaretskii 2021-03-29 11:53 ` bug#47408: Etags support for Mercury [v0.4] fabrice nicol 0 siblings, 1 reply; 27+ messages in thread From: Eli Zaretskii @ 2021-03-28 16:22 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 > From: fabrice nicol <fabrnicol@gmail.com> > Date: Sun, 28 Mar 2021 17:49:20 +0200 > > I left this couple of options in (following Francesco Potorti only for long options --declarations/--no-defines), > for two reasons: > > 1. The ambiguity between Objective C and Mercury > > Both languages having the same file extension .m, it was necessary to add in a heuristic test function, in the > absence of explicit language identification input from command line. > > Yet all heuristics may fail in rare cases. Tests show a fairly low failure rate on the Mercury compiler source > code. Less than 0.5 % of .m files are not identified as Mercury files by the test (this should have been > documented somewhere). File concerned by test failure are some Mercury test files and documentary test > files with only (or almost only) comments and blank lines. > > While this could be improved by tweaking the heuristic test, it would make it more complex, bug-prone and > ultimately hard to maintain. > > So -m/-M are useful to deal with these rare files, as they do not rely on the heuristic test function at all but on > their own semantics, which explicitly identifies Mercury. > > The only alternative I see is to explicitly warn users about adding '-l mercury' to command line when using > long options (in etags.1 and possibly other docs). I think "-l mercury" is indeed the way to tell etags this is a Mercury source. We never had language-specific options in etags, and I don't see a serious enough reason to introduce them now. I do find it unfortunate that Mercury uses the same extension as ObjC, but that's water under the bridge. Of course, if the heuristic test could be improved to make it err less, it would also be good. > diff --git a/lisp/speedbar.el b/lisp/speedbar.el > index 12e57b1108..63f3cd6ca1 100644 > --- a/lisp/speedbar.el > +++ b/lisp/speedbar.el > @@ -3534,6 +3534,8 @@ speedbar-fetch-etags-parse-list > speedbar-parse-c-or-c++tag) > ("^\\.emacs$\\|.\\(el\\|l\\|lsp\\)\\'" . > "def[^i]+\\s-+\\(\\(\\w\\|[-_]\\)+\\)\\s-*\C-?") > + ("^\\.m$\\'" . > + "\\(^:-\\)?\\s-*\\(\\(pred\\|func\\|type\\|instance\\|typeclass\\)+\\s+\\([a-z]+[a-zA-Z0-9_]*\\)+\\)\\s-*(?^?") > ; ("\\.\\([fF]\\|for\\|FOR\\|77\\|90\\)\\'" . > ; speedbar-parse-fortran77-tag) > ("\\.tex\\'" . speedbar-parse-tex-string) > > What about ObjC here? or are these keywords good for ObjC as well? > > has the following reply: Objective C .m files are not parsed by speedbar.el in current repository code, so the > added feature does not break anything. Issues will only arise if/when Emacs maintainers for Objective C > support decide on adding this file format to the speedbar parser. It would be premature (and out-of-place) > for me to settle this on my own. Should this move happen, the heuristics used in etags.c (function > test_objc_is_mercury) could then be ported to elisp code. OK, so please add there a comment to say that .m is also Objective C, but Speedbar doesn't support it yet. Thanks. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.4] 2021-03-28 16:22 ` Eli Zaretskii @ 2021-03-29 11:53 ` fabrice nicol [not found] ` <70503251-f8ea-9006-b7e7-b13b93bb71de@gmail.com> 0 siblings, 1 reply; 27+ messages in thread From: fabrice nicol @ 2021-03-29 11:53 UTC (permalink / raw) To: 47408 [-- Attachment #1: Type: text/plain, Size: 4484 bytes --] Attached is the new patch that integrates your indications. Please note two points: 1. Now that -m/-M have been done with, there is no use specifying any Mercury-specific behavior for --no-defines. Actually the Mercury community consensus is that all declarations should be tagged in any case. So --no-defines is just the default behavior of etags run without any option and does not need to be used explicitly or specifically documented. I followed your indications about --declarations. I also added a line to etags.1 about --language=mercury or --language=objc, should the heuristic test fail to detect the right language. Note, however, that removing language-specific options comes at a price. The heuristic test has now to be more complex. I had errless detection results against my test base of 4,000 mercury files and 500 Obj.-C files. This looks satisfactory but I had to tweak the heuristic test function (test_objc_is_mercury) quite a bit to weed out detection failures. I added the ChangeLog, the requested test file (array.m) under test/manual/etags/merc-src and altered the corresponding Makefile accordingly. 2. I removed by added line to speedbar.el, which in the end did not prove very useful. It is located in a Xemacs compatibility layer that is no longer used by most users. Le 28/03/2021 à 18:22, Eli Zaretskii a écrit : >> From: fabrice nicol <fabrnicol@gmail.com> >> Date: Sun, 28 Mar 2021 17:49:20 +0200 >> >> I left this couple of options in (following Francesco Potorti only for long options --declarations/--no-defines), >> for two reasons: >> >> 1. The ambiguity between Objective C and Mercury >> >> Both languages having the same file extension .m, it was necessary to add in a heuristic test function, in the >> absence of explicit language identification input from command line. >> >> Yet all heuristics may fail in rare cases. Tests show a fairly low failure rate on the Mercury compiler source >> code. Less than 0.5 % of .m files are not identified as Mercury files by the test (this should have been >> documented somewhere). File concerned by test failure are some Mercury test files and documentary test >> files with only (or almost only) comments and blank lines. >> >> While this could be improved by tweaking the heuristic test, it would make it more complex, bug-prone and >> ultimately hard to maintain. >> >> So -m/-M are useful to deal with these rare files, as they do not rely on the heuristic test function at all but on >> their own semantics, which explicitly identifies Mercury. >> >> The only alternative I see is to explicitly warn users about adding '-l mercury' to command line when using >> long options (in etags.1 and possibly other docs). > I think "-l mercury" is indeed the way to tell etags this is a Mercury > source. > > We never had language-specific options in etags, and I don't see a > serious enough reason to introduce them now. I do find it unfortunate > that Mercury uses the same extension as ObjC, but that's water under > the bridge. > > Of course, if the heuristic test could be improved to make it err > less, it would also be good. > >> diff --git a/lisp/speedbar.el b/lisp/speedbar.el >> index 12e57b1108..63f3cd6ca1 100644 >> --- a/lisp/speedbar.el >> +++ b/lisp/speedbar.el >> @@ -3534,6 +3534,8 @@ speedbar-fetch-etags-parse-list >> speedbar-parse-c-or-c++tag) >> ("^\\.emacs$\\|.\\(el\\|l\\|lsp\\)\\'" . >> "def[^i]+\\s-+\\(\\(\\w\\|[-_]\\)+\\)\\s-*\C-?") >> + ("^\\.m$\\'" . >> + "\\(^:-\\)?\\s-*\\(\\(pred\\|func\\|type\\|instance\\|typeclass\\)+\\s+\\([a-z]+[a-zA-Z0-9_]*\\)+\\)\\s-*(?^?") >> ; ("\\.\\([fF]\\|for\\|FOR\\|77\\|90\\)\\'" . >> ; speedbar-parse-fortran77-tag) >> ("\\.tex\\'" . speedbar-parse-tex-string) >> >> What about ObjC here? or are these keywords good for ObjC as well? >> >> has the following reply: Objective C .m files are not parsed by speedbar.el in current repository code, so the >> added feature does not break anything. Issues will only arise if/when Emacs maintainers for Objective C >> support decide on adding this file format to the speedbar parser. It would be premature (and out-of-place) >> for me to settle this on my own. Should this move happen, the heuristics used in etags.c (function >> test_objc_is_mercury) could then be ported to elisp code. > OK, so please add there a comment to say that .m is also Objective C, > but Speedbar doesn't support it yet. > > Thanks. [-- Attachment #2: 0001-Add-etags-support-for-Mercury-v0.4.patch --] [-- Type: text/x-patch, Size: 142648 bytes --] From a0781212917457d3569de941c80364523a422c08 Mon Sep 17 00:00:00 2001 From: Fabrice Nicol <fabrnicol@gmail.com> Date: Mon, 29 Mar 2021 10:55:27 +0200 Subject: [PATCH] Add etags support for Mercury [v0.4] --- doc/man/etags.1 | 23 +- etc/NEWS | 7 + lib-src/ChangeLog | 14 + lib-src/etags.c | 490 +++- test/manual/etags/Makefile | 3 +- test/manual/etags/merc-src/array.m | 3416 ++++++++++++++++++++++++++++ 6 files changed, 3940 insertions(+), 13 deletions(-) create mode 100644 lib-src/ChangeLog create mode 100644 test/manual/etags/merc-src/array.m diff --git a/doc/man/etags.1 b/doc/man/etags.1 index c5c15fb182..4a908fc0a0 100644 --- a/doc/man/etags.1 +++ b/doc/man/etags.1 @@ -1,5 +1,5 @@ .\" See section COPYING for copyright and redistribution information. -.TH ETAGS 1 "2019-06-24" "GNU Tools" "GNU" +.TH ETAGS 1 "2021-03-30" "GNU Tools" "GNU" .de BP .sp .ti -.2i @@ -50,9 +50,9 @@ format understood by .BR vi ( 1 )\c \&. Both forms of the program understand the syntax of C, Objective C, C++, Java, Fortran, Ada, Cobol, Erlang, -Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Pascal, Perl, -Ruby, PHP, PostScript, Python, Prolog, Scheme and -most assembler\-like syntaxes. +Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Mercury, Pascal, +Perl, Ruby, PHP, PostScript, Python, Prolog, Scheme and most assembler\-like +syntaxes. Both forms read the files specified on the command line, and write a tag table (defaults: \fBTAGS\fP for \fBetags\fP, \fBtags\fP for \fBctags\fP) in the current working directory. @@ -91,6 +91,9 @@ Only \fBctags\fP accepts this option. In C and derived languages, create tags for function declarations, and create tags for extern variables unless \-\-no\-globals is used. In Lisp, create tags for (defvar foo) declarations. +In Mercury, declarations start a line with "\|\fB:-\fP\|" and are tagged +by default. This option also tags predicates or functions in first rules +of clauses, as in Prolog. .TP .B \-D, \-\-no\-defines Do not create tag entries for C preprocessor constant definitions @@ -125,10 +128,14 @@ final brace of a function or structure definition in C and C++. Parse the following files according to the given language. More than one such options may be intermixed with filenames. Use \fB\-\-help\fP to get a list of the available languages and their default filename -extensions. The "auto" language can be used to restore automatic -detection of language based on the file name. The "none" -language may be used to disable language parsing altogether; only -regexp matching is done in this case (see the \fB\-\-regex\fP option). +extensions. For example, as Mercury and Objective-C have same +filename extension \fI.m\fP, a test based on contents tries to detect +the language. If this test fails, \fB\-\-language=\fP\fImercury\fP or +\fB\-\-language=\fP\fIobjc\fP should be used. +The "auto" language can be used to restore automatic detection of language +based on the file name. The "none" language may be used to disable language +parsing altogether; only regexp matching is done in this case (see the +\fB\-\-regex\fP option). .TP .B \-\-members Create tag entries for variables that are members of structure-like diff --git a/etc/NEWS b/etc/NEWS index 2d66a93474..8afb7c76b4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -93,6 +93,13 @@ useful on systems such as FreeBSD which ships only with "etc/termcap". \f * Changes in Emacs 28.1 ++++ +** Etags support for the Mercury programming language (https://mercurylang.org). +** Etags command line option --declarations now has Mercury-specific behavior. +All Mercury declarations are tagged by default. +For compatibility with Prolog etags support, predicates and functions appearing +first in clauses will also be tagged if etags is run with '--declarations'. + +++ ** New command 'font-lock-update', bound to 'C-x x f'. This command updates the syntax highlighting in this buffer. diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog new file mode 100644 index 0000000000..3ab71a4dab --- /dev/null +++ b/lib-src/ChangeLog @@ -0,0 +1,14 @@ +Add etags support for Mercury (https://mercurylang.org) + +Tag declarations starting lines with ':-'. +By default, all declarations are tagged. Optionally, first predicate or +functions in clauses can be tagged as in Prolog support using --declarations +(Bug#47408). +* lib-src/etags.c (test_objc_is_mercury, Mercury_functions) +(mercury_skip_comment, mercury_decl, mercury_pr): +Implement Mercury support. As Mercury and Objective-C have same file extension +.m, a heuristic test tries to detect the language. +If this test fails, --language=mercury should be used. +* doc/man/etags.1: Document the change. Add Mercury-specific behavior for +--declarations. This option tags first predicates or functions in clauses in +addition to declarations. diff --git a/lib-src/etags.c b/lib-src/etags.c index b5c18e0e01..a5c5224e63 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -142,7 +142,14 @@ Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2021 Free Software # define CTAGS false #endif -/* Copy to DEST from SRC (containing LEN bytes), and append a NUL byte. */ +/* Define MERCURY_HEURISTICS_RATIO as it was necessary to disambiguate + Mercury from Objective C, which have same file extensions .m + See comments before function test_objc_is_mercury for details. */ +#ifndef MERCURY_HEURISTICS_RATIO +# define MERCURY_HEURISTICS_RATIO 0.5 +#endif + +/* COPY to DEST from SRC (containing LEN bytes), and append a NUL byte. */ static void memcpyz (void *dest, void const *src, ptrdiff_t len) { @@ -359,6 +366,7 @@ #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op))) static void Lisp_functions (FILE *); static void Lua_functions (FILE *); static void Makefile_targets (FILE *); +static void Mercury_functions (FILE *); static void Pascal_functions (FILE *); static void Perl_functions (FILE *); static void PHP_functions (FILE *); @@ -378,6 +386,7 @@ #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op))) static bool nocase_tail (const char *); static void get_tag (char *, char **); static void get_lispy_tag (char *); +static void test_objc_is_mercury(char *, language **); static void analyze_regex (char *); static void free_regexps (void); @@ -683,10 +692,22 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ "In makefiles, targets are tags; additionally, variables are tags\n\ unless you specify '--no-globals'."; +/* Mercury and Objective C share the same .m file extensions. */ +static const char *Mercury_suffixes [] = + {"m", + NULL}; +static const char Mercury_help [] = + "In Mercury code, tags are all declarations beginning a line with ':-'\n\ +and optionally Prolog-like definitions (first rule for a predicate or \ +function).\n\ +To enable this behavior, run etags using --declarations."; +static bool with_mercury_definitions = false; +float mercury_heuristics_ratio = MERCURY_HEURISTICS_RATIO; + static const char *Objc_suffixes [] = - { "lm", /* Objective lex file */ - "m", /* Objective C file */ - NULL }; + { "lm", /* Objective lex file */ + "m", /* By default, Objective C file will be assumed. */ + NULL}; static const char Objc_help [] = "In Objective C code, tags include Objective C definitions for classes,\n\ class categories, methods and protocols. Tags for variables and\n\ @@ -824,7 +845,9 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ { "lisp", Lisp_help, Lisp_functions, Lisp_suffixes }, { "lua", Lua_help,Lua_functions,Lua_suffixes,NULL,Lua_interpreters}, { "makefile", Makefile_help,Makefile_targets,NULL,Makefile_filenames}, + /* objc listed before mercury as it is a better default for .m extensions. */ { "objc", Objc_help, plain_C_entries, Objc_suffixes }, + { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes }, { "pascal", Pascal_help, Pascal_functions, Pascal_suffixes }, { "perl",Perl_help,Perl_functions,Perl_suffixes,NULL,Perl_interpreters}, { "php", PHP_help, PHP_functions, PHP_suffixes }, @@ -950,6 +973,9 @@ print_help (argument *argbuffer) puts ("\tand create tags for extern variables unless --no-globals is used."); + puts ("In Mercury, tag both declarations starting a line with ':-' and first\n\ + predicates or functions in clauses."); + if (CTAGS) puts ("-d, --defines\n\ Create tag entries for C #define constants and enum constants, too."); @@ -1775,6 +1801,11 @@ find_entries (FILE *inf) if (parser == NULL) { lang = get_language_from_filename (curfdp->infname, true); + + /* Disambiguate file names between Objc and Mercury */ + if (lang != NULL && strcmp(lang->name, "objc") == 0) + test_objc_is_mercury(curfdp->infname, &lang); + if (lang != NULL && lang->function != NULL) { curfdp->lang = lang; @@ -6019,6 +6050,457 @@ prolog_atom (char *s, size_t pos) return 0; } +\f +/* + * Support for Mercury + * + * Assumes that the declarationa starts at column 0. + * Original code by Sunichirou Sugou (1989) for Prolog. + * Rewritten by Anders Lindgren (1996) for Prolog. + * Adapted by Fabrice Nicol (2021) for Mercury. + * Note: Prolog-support behavior is preserved if + * --declarations is used, corresponding to + * with_mercury_definitions=true. + */ + +static ptrdiff_t mercury_pr (char *, char *, ptrdiff_t); +static void mercury_skip_comment (linebuffer *, FILE *); +static bool is_mercury_type = false; +static bool is_mercury_quantifier = false; +static bool is_mercury_declaration = false; + +/* + * Objective-C and Mercury have identical file extension .m + * To disambiguate between Objective C and Mercury, parse file + * with the following heuristics hook: + * - if line starts with :- choose Mercury unconditionally, + * - if line starts with #, @, choose Objective-C, + * - otherwise compute the following ratio: + * + * r = (number of lines with :- + * or % in non-commented parts or . at trimmed EOL) + * / (number of lines - number of lines starting by any amount + * of whitespace, optionally followed by comment(s)) + * + * Note: strings are neglected in counts. + * + * If r > mercury_heuristics_ratio, choose Mercury. + * Experimental tests show that a possibly optimal default value for + * this floor value is around 0.5. This is the default value for + * MERCURY_HEURISTICS_RATIO, defined in the first lines of this file. + * The closer r to 0.5, the closer the source code to pure Prolog. + * Idiomatic Mercury is scored either with r = 1.0 or higher. + * Objective-C is scored with r = 0.0. When this fails, the r-score never + * rose above 0.1 in Objective-C tests. + */ + +static void +test_objc_is_mercury (char *this_file, language **lang) +{ + if (this_file == NULL) return; + FILE* fp = fopen (this_file, "r"); + if (fp == NULL) + pfatal (this_file); + + bool blank_line = false; /* Line starting with any amount of white space + followed by optional comment(s). */ + bool commented_line = false; + bool found_dot = false; + bool only_space_before = true; + bool start_of_line = true; + int c; + intmax_t lines = 1; + intmax_t mercury_dots = 0; + intmax_t percentage_signs = 0; + intmax_t rule_signs = 0; + float ratio = 0; + + while ((c = fgetc (fp)) != EOF) + { + switch (c) + { + case '\n': + if (! blank_line) ++lines; + blank_line = true; + commented_line = false; + start_of_line = true; + if (found_dot) ++mercury_dots; + found_dot = false; + only_space_before = true; + break; + case '.': + found_dot = ! commented_line; + only_space_before = false; + break; + case '%': /* More frequent in Mercury. May be modulo in Obj.-C. */ + if (! commented_line) + { + ++percentage_signs; + /* Cannot tell if it is a comment or modulo yet for sure. + Yet works for heuristic purposes. */ + commented_line = true; + } + found_dot = false; + start_of_line = false; + only_space_before = false; + break; + case '/': + { + int d = fgetc(fp); + found_dot = false; + only_space_before = false; + if (! commented_line) + { + if (d == '*') + commented_line = true; + else + /* If d == '/', cannot tell if it is an Obj.-C comment: + may be Mercury integ. division. */ + blank_line = false; + } + } + FALLTHROUGH; + case ' ': + case '\t': + start_of_line = false; + break; + case ':': + c = fgetc(fp); + if (start_of_line) + { + if (c == '-') + { + ratio = 1.0; /* Failsafe, not an operator in Obj.-C. */ + goto out; + } + start_of_line = false; + } + else + { + /* p :- q. Frequent in Mercury. + Rare or in quoted exprs in Obj.-C. */ + if (c == '-' && ! commented_line) + ++rule_signs; + } + blank_line = false; + found_dot = false; + only_space_before = false; + break; + case '@': + case '#': + if (start_of_line || only_space_before) + { + ratio = 0.0; + goto out; + } + FALLTHROUGH; + default: + start_of_line = false; + blank_line = false; + found_dot = false; + only_space_before = false; + } + } + + /* Fallback heuristic test. Not failsafe but errless in pratice. */ + ratio = ((float) rule_signs + percentage_signs + mercury_dots) / lines; + + out: + if (fclose(fp) == EOF) + pfatal(this_file); + + if (ratio > mercury_heuristics_ratio) + { + /* Change the language from Objective C to Mercury. */ + static language lang0 = { "mercury", Mercury_help, Mercury_functions, + Mercury_suffixes }; + *lang = &lang0; + } +} + +static void +Mercury_functions (FILE *inf) +{ + char *cp, *last = NULL; + ptrdiff_t lastlen = 0, allocated = 0; + if (declarations) with_mercury_definitions = true; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + if (cp[0] == '\0') /* Empty line. */ + continue; + else if (c_isspace (cp[0]) || cp[0] == '%') + /* A Prolog-type comment or anything other than a declaration. */ + continue; + else if (cp[0] == '/' && cp[1] == '*') /* Mercury C-type comment. */ + mercury_skip_comment (&lb, inf); + else + { + is_mercury_declaration = (cp[0] == ':' && cp[1] == '-'); + + if (is_mercury_declaration + || with_mercury_definitions) + { + ptrdiff_t len = mercury_pr (cp, last, lastlen); + if (0 < len) + { + /* Store the declaration to avoid generating duplicate + tags later. */ + if (allocated <= len) + { + xrnew (last, len + 1, 1); + allocated = len + 1; + } + memcpyz (last, cp, len); + lastlen = len; + } + } + } + } + free (last); +} + +static void +mercury_skip_comment (linebuffer *plb, FILE *inf) +{ + char *cp; + + do + { + for (cp = plb->buffer; *cp != '\0'; ++cp) + if (cp[0] == '*' && cp[1] == '/') + return; + readline (plb, inf); + } + while (perhaps_more_input (inf)); +} + +/* + * A declaration is added if it matches: + * <beginning of line>:-<whitespace><Mercury Term><whitespace>( + * If with_mercury_definitions == true, we also add: + * <beginning of line><Mercury item><whitespace>( + * or <beginning of line><Mercury item><whitespace>:- + * As for Prolog support, different arities and types are not taken into + * consideration. + * Item is added to the tags database if it doesn't match the + * name of the previous declaration. + * + * Consume a Mercury declaration. + * Return the number of bytes consumed, or 0 if there was an error. + * + * A Mercury declaration must be one of: + * :- type + * :- solver type + * :- pred + * :- func + * :- inst + * :- mode + * :- typeclass + * :- instance + * :- pragma + * :- promise + * :- initialise + * :- finalise + * :- mutable + * :- module + * :- interface + * :- implementation + * :- import_module + * :- use_module + * :- include_module + * :- end_module + * followed on the same line by an alphanumeric sequence, starting with a lower + * case letter or by a single-quoted arbitrary string. + * Single quotes can escape themselves. Backslash quotes everything. + * + * Return the size of the name of the declaration or 0 if no header was found. + * As quantifiers may precede functions or predicates, we must list them too. + */ + +static const char *Mercury_decl_tags[] = {"type", "solver type", "pred", + "func", "inst", "mode", "typeclass", "instance", "pragma", "promise", + "initialise", "finalise", "mutable", "module", "interface", "implementation", + "import_module", "use_module", "include_module", "end_module", "some", "all"}; + +static size_t +mercury_decl (char *s, size_t pos) +{ + if (s == NULL) return 0; + + size_t origpos; + origpos = pos; + + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) ++pos; + + unsigned char decl_type_length = pos - origpos; + char buf[decl_type_length + 1]; + memset (buf, 0, decl_type_length + 1); + + /* Mercury declaration tags. Consume them, then check the declaration item + following :- is legitimate, then go on as in the prolog case. */ + + memcpy (buf, &s[origpos], decl_type_length); + + bool found_decl_tag = false; + + if (is_mercury_quantifier) + { + if (strcmp (buf, "pred") != 0 && strcmp (buf, "func") != 0) /* Bad syntax. */ + return 0; + is_mercury_quantifier = false; /* Beset to base value. */ + found_decl_tag = true; + } + else + { + for (int j = 0; j < sizeof (Mercury_decl_tags) / sizeof (char*); ++j) + { + if (strcmp (buf, Mercury_decl_tags[j]) == 0) + { + found_decl_tag = true; + if (strcmp (buf, "type") == 0) + is_mercury_type = true; + + if (strcmp (buf, "some") == 0 + || strcmp (buf, "all") == 0) + { + is_mercury_quantifier = true; + } + + break; /* Found declaration tag of rank j. */ + } + else + /* 'solver type' has a blank in the middle, + so this is the hard case. */ + if (strcmp (buf, "solver") == 0) + { + ++pos; + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) + ++pos; + + decl_type_length = pos - origpos; + char buf2[decl_type_length + 1]; + memset (buf2, 0, decl_type_length + 1); + memcpy (buf2, &s[origpos], decl_type_length); + + if (strcmp (buf2, "solver type") == 0) + { + found_decl_tag = false; + break; /* Found declaration tag of rank j. */ + } + } + } + } + + /* If with_mercury_definitions == false + * this is a Mercury syntax error, ignoring... */ + + if (with_mercury_definitions) + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */ + else + /* Prolog-like behavior + * we have parsed the predicate once, yet inappropriately + * so restarting again the parsing step. */ + pos = 0; + } + else + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */ + else + return 0; + } + + /* From now on it is the same as for Prolog except for module dots. */ + + if (c_islower (s[pos]) || s[pos] == '_' ) + { + /* The name is unquoted. + Do not confuse module dots with end-of-declaration dots. */ + + while (c_isalnum (s[pos]) + || s[pos] == '_' + || (s[pos] == '.' /* A module dot. */ + && s + pos + 1 != NULL + && (c_isalnum (s[pos + 1]) || s[pos + 1] == '_'))) + ++pos; + + return pos - origpos; + } + else if (s[pos] == '\'') + { + ++pos; + for (;;) + { + if (s[pos] == '\'') + { + ++pos; + if (s[pos] != '\'') + break; + ++pos; /* A double quote. */ + } + else if (s[pos] == '\0') /* Multiline quoted atoms are ignored. */ + return 0; + else if (s[pos] == '\\') + { + if (s[pos+1] == '\0') + return 0; + pos += 2; + } + else + ++pos; + } + return pos - origpos; + } + else if (is_mercury_quantifier && s[pos] == '[') /* :- some [T] pred/func. */ + { + for (++pos; s + pos != NULL && s[pos] != ']'; ++pos) {} + if (s + pos == NULL) return 0; + ++pos; + pos = skip_spaces (s + pos) - s; + return mercury_decl (s, pos) + pos - origpos; + } + else + return 0; +} + +static ptrdiff_t +mercury_pr (char *s, char *last, ptrdiff_t lastlen) +{ + size_t len0 = 0; + is_mercury_type = false; + is_mercury_quantifier = false; + + if (is_mercury_declaration) + { + /* Skip len0 blanks only for declarations. */ + len0 = skip_spaces (s + 2) - s; + } + + size_t len = mercury_decl (s , len0); + if (len == 0) return 0; + len += len0; + + if (( (s[len] == '.' /* This is a statement dot, not a module dot. */ + || (s[len] == '(' && (len += 1)) + || (s[len] == ':' /* Stopping in case of a rule. */ + && s[len + 1] == '-' + && (len += 2))) + && (lastlen != len || memcmp (s, last, len) != 0) + ) + /* Types are often declared on several lines so keeping just + the first line. */ + || is_mercury_type) + { + make_tag (s, 0, true, s, len, lineno, linecharno); + return len; + } + + return 0; +} + \f /* * Support for Erlang diff --git a/test/manual/etags/Makefile b/test/manual/etags/Makefile index c1df703905..eae6918256 100644 --- a/test/manual/etags/Makefile +++ b/test/manual/etags/Makefile @@ -28,10 +28,11 @@ RBSRC= SCMSRC=$(addprefix ./scm-src/,test.scm) TEXSRC=$(addprefix ./tex-src/,testenv.tex gzip.texi texinfo.tex nonewline.tex) YSRC=$(addprefix ./y-src/,parse.y parse.c atest.y cccp.c cccp.y) +MERCSRC=$(addprefix ./merc-src/,array.m) SRCS=${ADASRC} ${ASRC} ${CSRC} ${CPSRC} ${ELSRC} ${ERLSRC} ${FSRC}\ ${FORTHSRC} ${GOSRC} ${HTMLSRC} ${JAVASRC} ${LUASRC} ${MAKESRC}\ ${OBJCSRC} ${OBJCPPSRC} ${PASSRC} ${PHPSRC} ${PERLSRC} ${PSSRC}\ - ${PROLSRC} ${PYTSRC} ${RBSRC} ${SCMSRC} ${TEXSRC} ${YSRC} + ${PROLSRC} ${PYTSRC} ${RBSRC} ${SCMSRC} ${TEXSRC} ${YSRC} ${MERCSRC} NONSRCS=./f-src/entry.strange ./erl-src/lists.erl ./cp-src/clheir.hpp.gz ETAGS_PROG=../../../lib-src/etags diff --git a/test/manual/etags/merc-src/array.m b/test/manual/etags/merc-src/array.m new file mode 100644 index 0000000000..0663c41087 --- /dev/null +++ b/test/manual/etags/merc-src/array.m @@ -0,0 +1,3416 @@ +%---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% +% Copyright (C) 1993-1995, 1997-2012 The University of Melbourne. +% Copyright (C) 2013-2018 The Mercury team. +% This file is distributed under the terms specified in COPYING.LIB. +%---------------------------------------------------------------------------% +% +% File: array.m. +% Main authors: fjh, bromage. +% Stability: medium-low. +% +% This module provides dynamically-sized one-dimensional arrays. +% Array indices start at zero. +% +% WARNING! +% +% Arrays are currently not unique objects. until this situation is resolved, +% it is up to the programmer to ensure that arrays are used in ways that +% preserve correctness. In the absence of mode reordering, one should therefore +% assume that evaluation will take place in left-to-right order. For example, +% the following code will probably not work as expected (f is a function, +% A an array, I an index, and X an appropriate value): +% +% Y = f(A ^ elem(I) := X, A ^ elem(I)) +% +% The compiler is likely to compile this as +% +% V0 = A ^ elem(I) := X, +% V1 = A ^ elem(I), +% Y = f(V0, V1) +% +% and will be unaware that the first line should be ordered *after* the second. +% The safest thing to do is write things out by hand in the form +% +% A0I = A0 ^ elem(I), +% A1 = A0 ^ elem(I) := X, +% Y = f(A1, A0I) +% +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- module array. +:- interface. + +:- import_module list. +:- import_module pretty_printer. +:- import_module random. + +:- type array(T). + +:- inst array(I) == ground. +:- inst array == array(ground). + + % XXX the current Mercury compiler doesn't support `ui' modes, + % so to work-around that problem, we currently don't use + % unique modes in this module. + +% :- inst uniq_array(I) == unique. +% :- inst uniq_array == uniq_array(unique). +:- inst uniq_array(I) == array(I). % XXX work-around +:- inst uniq_array == uniq_array(ground). % XXX work-around + +:- mode array_di == di(uniq_array). +:- mode array_uo == out(uniq_array). +:- mode array_ui == in(uniq_array). + +% :- inst mostly_uniq_array(I) == mostly_unique). +% :- inst mostly_uniq_array == mostly_uniq_array(mostly_unique). +:- inst mostly_uniq_array(I) == array(I). % XXX work-around +:- inst mostly_uniq_array == mostly_uniq_array(ground). % XXX work-around + +:- mode array_mdi == mdi(mostly_uniq_array). +:- mode array_muo == out(mostly_uniq_array). +:- mode array_mui == in(mostly_uniq_array). + + % An `index_out_of_bounds' is the exception thrown + % on out-of-bounds array accesses. The string describes + % the predicate or function reporting the error. +:- type index_out_of_bounds + ---> index_out_of_bounds(string). + +%---------------------------------------------------------------------------% + + % make_empty_array(Array) creates an array of size zero + % starting at lower bound 0. + % +:- pred make_empty_array(array(T)::array_uo) is det. + +:- func make_empty_array = (array(T)::array_uo) is det. + + % init(Size, Init, Array) creates an array with bounds from 0 + % to Size-1, with each element initialized to Init. Throws an + % exception if Size < 0. + % +:- pred init(int, T, array(T)). +:- mode init(in, in, array_uo) is det. + +:- func init(int, T) = array(T). +:- mode init(in, in) = array_uo is det. + + % array/1 is a function that constructs an array from a list. + % (It does the same thing as the predicate from_list/2.) + % The syntax `array([...])' is used to represent arrays + % for io.read, io.write, term_to_type, and type_to_term. + % +:- func array(list(T)) = array(T). +:- mode array(in) = array_uo is det. + + % generate(Size, Generate) = Array: + % Create an array with bounds from 0 to Size - 1 using the function + % Generate to set the initial value of each element of the array. + % The initial value of the element at index K will be the result of + % calling the function Generate(K). Throws an exception if Size < 0. + % +:- func generate(int::in, (func(int) = T)::in) = (array(T)::array_uo) + is det. + + % generate_foldl(Size, Generate, Array, !Acc): + % As above, but using a predicate with an accumulator threaded through it + % to generate the initial value of each element. + % +:- pred generate_foldl(int, pred(int, T, A, A), array(T), A, A). +:- mode generate_foldl(in, in(pred(in, out, in, out) is det), + array_uo, in, out) is det. +:- mode generate_foldl(in, in(pred(in, out, mdi, muo) is det), + array_uo, mdi, muo) is det. +:- mode generate_foldl(in, in(pred(in, out, di, uo) is det), + array_uo, di, uo) is det. +:- mode generate_foldl(in, in(pred(in, out, in, out) is semidet), + array_uo, in, out) is semidet. +:- mode generate_foldl(in, in(pred(in, out, mdi, muo) is semidet), + array_uo, mdi, muo) is semidet. +:- mode generate_foldl(in, in(pred(in, out, di, uo) is semidet), + array_uo, di, uo) is semidet. + +%---------------------------------------------------------------------------% + + % min returns the lower bound of the array. + % Note: in this implementation, the lower bound is always zero. + % +:- pred min(array(_T), int). +%:- mode min(array_ui, out) is det. +:- mode min(in, out) is det. + +:- func min(array(_T)) = int. +%:- mode min(array_ui) = out is det. +:- mode min(in) = out is det. + + % det_least_index returns the lower bound of the array. + % Throws an exception if the array is empty. + % +:- func det_least_index(array(T)) = int. +%:- mode det_least_index(array_ui) = out is det. +:- mode det_least_index(in) = out is det. + + % semidet_least_index returns the lower bound of the array, + % or fails if the array is empty. + % +:- func semidet_least_index(array(T)) = int. +%:- mode semidet_least_index(array_ui) = out is semidet. +:- mode semidet_least_index(in) = out is semidet. + + % max returns the upper bound of the array. + % Returns lower bound - 1 for an empty array + % (always -1 in this implementation). + % +:- pred max(array(_T), int). +%:- mode max(array_ui, out) is det. +:- mode max(in, out) is det. + +:- func max(array(_T)) = int. +%:- mode max(array_ui) = out is det. +:- mode max(in) = out is det. + + % det_greatest_index returns the upper bound of the array. + % Throws an exception if the array is empty. + % +:- func det_greatest_index(array(T)) = int. +%:- mode det_greatest_index(array_ui) = out is det. +:- mode det_greatest_index(in) = out is det. + + % semidet_greatest_index returns the upper bound of the array, + % or fails if the array is empty. + % +:- func semidet_greatest_index(array(T)) = int. +%:- mode semidet_greatest_index(array_ui) = out is semidet. +:- mode semidet_greatest_index(in) = out is semidet. + + % size returns the length of the array, + % i.e. upper bound - lower bound + 1. + % +:- pred size(array(_T), int). +%:- mode size(array_ui, out) is det. +:- mode size(in, out) is det. + +:- func size(array(_T)) = int. +%:- mode size(array_ui) = out is det. +:- mode size(in) = out is det. + + % bounds(Array, Min, Max) returns the lower and upper bounds of an array. + % The upper bound will be lower bound - 1 for an empty array. + % Note: in this implementation, the lower bound is always zero. + % +:- pred bounds(array(_T), int, int). +%:- mode bounds(array_ui, out, out) is det. +:- mode bounds(in, out, out) is det. + + % in_bounds checks whether an index is in the bounds of an array. + % +:- pred in_bounds(array(_T), int). +%:- mode in_bounds(array_ui, in) is semidet. +:- mode in_bounds(in, in) is semidet. + + % is_empty(Array): + % True iff Array is an array of size zero. + % +:- pred is_empty(array(_T)). +%:- mode is_empty(array_ui) is semidet. +:- mode is_empty(in) is semidet. + +%---------------------------------------------------------------------------% + + % lookup returns the N'th element of an array. + % Throws an exception if the index is out of bounds. + % +:- pred lookup(array(T), int, T). +%:- mode lookup(array_ui, in, out) is det. +:- mode lookup(in, in, out) is det. + +:- func lookup(array(T), int) = T. +%:- mode lookup(array_ui, in) = out is det. +:- mode lookup(in, in) = out is det. + + % semidet_lookup returns the N'th element of an array. + % It fails if the index is out of bounds. + % +:- pred semidet_lookup(array(T), int, T). +%:- mode semidet_lookup(array_ui, in, out) is semidet. +:- mode semidet_lookup(in, in, out) is semidet. + + % unsafe_lookup returns the N'th element of an array. + % It is an error if the index is out of bounds. + % +:- pred unsafe_lookup(array(T), int, T). +%:- mode unsafe_lookup(array_ui, in, out) is det. +:- mode unsafe_lookup(in, in, out) is det. + + % set sets the N'th element of an array, and returns the + % resulting array (good opportunity for destructive update ;-). + % Throws an exception if the index is out of bounds. + % +:- pred set(int, T, array(T), array(T)). +:- mode set(in, in, array_di, array_uo) is det. + +:- func set(array(T), int, T) = array(T). +:- mode set(array_di, in, in) = array_uo is det. + + % semidet_set sets the nth element of an array, and returns + % the resulting array. It fails if the index is out of bounds. + % +:- pred semidet_set(int, T, array(T), array(T)). +:- mode semidet_set(in, in, array_di, array_uo) is semidet. + + % unsafe_set sets the nth element of an array, and returns the + % resulting array. It is an error if the index is out of bounds. + % +:- pred unsafe_set(int, T, array(T), array(T)). +:- mode unsafe_set(in, in, array_di, array_uo) is det. + + % slow_set sets the nth element of an array, and returns the + % resulting array. The initial array is not required to be unique, + % so the implementation may not be able to use destructive update. + % It is an error if the index is out of bounds. + % +:- pred slow_set(int, T, array(T), array(T)). +%:- mode slow_set(in, in, array_ui, array_uo) is det. +:- mode slow_set(in, in, in, array_uo) is det. + +:- func slow_set(array(T), int, T) = array(T). +%:- mode slow_set(array_ui, in, in) = array_uo is det. +:- mode slow_set(in, in, in) = array_uo is det. + + % semidet_slow_set sets the nth element of an array, and returns + % the resulting array. The initial array is not required to be unique, + % so the implementation may not be able to use destructive update. + % It fails if the index is out of bounds. + % +:- pred semidet_slow_set(int, T, array(T), array(T)). +%:- mode semidet_slow_set(in, in, array_ui, array_uo) is semidet. +:- mode semidet_slow_set(in, in, in, array_uo) is semidet. + + % Field selection for arrays. + % Array ^ elem(Index) = lookup(Array, Index). + % +:- func elem(int, array(T)) = T. +%:- mode elem(in, array_ui) = out is det. +:- mode elem(in, in) = out is det. + + % As above, but omit the bounds check. + % +:- func unsafe_elem(int, array(T)) = T. +%:- mode unsafe_elem(in, array_ui) = out is det. +:- mode unsafe_elem(in, in) = out is det. + + % Field update for arrays. + % (Array ^ elem(Index) := Value) = set(Array, Index, Value). + % +:- func 'elem :='(int, array(T), T) = array(T). +:- mode 'elem :='(in, array_di, in) = array_uo is det. + + % As above, but omit the bounds check. + % +:- func 'unsafe_elem :='(int, array(T), T) = array(T). +:- mode 'unsafe_elem :='(in, array_di, in) = array_uo is det. + + % swap(I, J, !Array): + % Swap the item in the I'th position with the item in the J'th position. + % Throws an exception if either of I or J is out-of-bounds. + % +:- pred swap(int, int, array(T), array(T)). +:- mode swap(in, in, array_di, array_uo) is det. + + % As above, but omit the bounds checks. + % +:- pred unsafe_swap(int, int, array(T), array(T)). +:- mode unsafe_swap(in, in, array_di, array_uo) is det. + + % Returns every element of the array, one by one. + % +:- pred member(array(T)::in, T::out) is nondet. + +%---------------------------------------------------------------------------% + + % copy(Array0, Array): + % Makes a new unique copy of an array. + % +:- pred copy(array(T), array(T)). +%:- mode copy(array_ui, array_uo) is det. +:- mode copy(in, array_uo) is det. + +:- func copy(array(T)) = array(T). +%:- mode copy(array_ui) = array_uo is det. +:- mode copy(in) = array_uo is det. + + % resize(Size, Init, Array0, Array): + % The array is expanded or shrunk to make it fit the new size `Size'. + % Any new entries are filled with `Init'. Throws an exception if + % `Size' < 0. + % +:- pred resize(int, T, array(T), array(T)). +:- mode resize(in, in, array_di, array_uo) is det. + + % resize(Array0, Size, Init) = Array: + % The array is expanded or shrunk to make it fit the new size `Size'. + % Any new entries are filled with `Init'. Throws an exception if + % `Size' < 0. + % +:- func resize(array(T), int, T) = array(T). +:- mode resize(array_di, in, in) = array_uo is det. + + % shrink(Size, Array0, Array): + % The array is shrunk to make it fit the new size `Size'. + % Throws an exception if `Size' is larger than the size of `Array0' or + % if `Size' < 0. + % +:- pred shrink(int, array(T), array(T)). +:- mode shrink(in, array_di, array_uo) is det. + + % shrink(Array0, Size) = Array: + % The array is shrunk to make it fit the new size `Size'. + % Throws an exception if `Size' is larger than the size of `Array0' or + % if `Size' < 0. + % +:- func shrink(array(T), int) = array(T). +:- mode shrink(array_di, in) = array_uo is det. + + % fill(Item, Array0, Array): + % Sets every element of the array to `Elem'. + % +:- pred fill(T::in, array(T)::array_di, array(T)::array_uo) is det. + + % fill_range(Item, Lo, Hi, !Array): + % Sets every element of the array with index in the range Lo..Hi + % (inclusive) to Item. Throws a software_error/1 exception if Lo > Hi. + % Throws an index_out_of_bounds/0 exception if Lo or Hi is out of bounds. + % +:- pred fill_range(T::in, int::in, int::in, + array(T)::array_di, array(T)::array_uo) is det. + + % from_list takes a list, and returns an array containing those + % elements in the same order that they occurred in the list. + % +:- func from_list(list(T)::in) = (array(T)::array_uo) is det. +:- pred from_list(list(T)::in, array(T)::array_uo) is det. + + % from_reverse_list takes a list, and returns an array containing + % those elements in the reverse order that they occurred in the list. + % +:- func from_reverse_list(list(T)::in) = (array(T)::array_uo) is det. + + % to_list takes an array and returns a list containing the elements + % of the array in the same order that they occurred in the array. + % +:- pred to_list(array(T), list(T)). +%:- mode to_list(array_ui, out) is det. +:- mode to_list(in, out) is det. + +:- func to_list(array(T)) = list(T). +%:- mode to_list(array_ui) = out is det. +:- mode to_list(in) = out is det. + + % fetch_items(Array, Lo, Hi, List): + % Returns a list containing the items in the array with index in the range + % Lo..Hi (both inclusive) in the same order that they occurred in the + % array. Returns an empty list if Hi < Lo. Throws an index_out_of_bounds/0 + % exception if either Lo or Hi is out of bounds, *and* Hi >= Lo. + % + % If Hi < Lo, we do not generate an exception even if either or both + % are out of bounds, for two reasons. First, there is no need; if Hi < Lo, + % we can return the empty list without accessing any element of the array. + % Second, without this rule, some programming techniques for accessing + % consecutive contiguous regions of an array would require explicit + % bound checks in the *caller* of fetch_items, which would duplicate + % the checks inside fetch_items itself. + % +:- pred fetch_items(array(T), int, int, list(T)). +:- mode fetch_items(in, in, in, out) is det. + +:- func fetch_items(array(T), int, int) = list(T). +%:- mode fetch_items(array_ui, in, in) = out is det. +:- mode fetch_items(in, in, in) = out is det. + + % binary_search(A, X, I) does a binary search for the element X + % in the array A. If there is an element with that value in the array, + % it returns its index I; otherwise, it fails. + % + % The array A must be sorted into ascending order with respect to the + % the builtin Mercury order on terms for binary_search/3, and with respect + % to supplied comparison predicate for binary_search/4. + % + % The array may contain duplicates. If it does, and a search looks for + % a duplicated value, the search will return the index of one of the + % copies, but it is not specified *which* copy's index it will return. + % +:- pred binary_search(array(T)::array_ui, + T::in, int::out) is semidet. +:- pred binary_search(comparison_func(T)::in, array(T)::array_ui, + T::in, int::out) is semidet. + + % approx_binary_search(A, X, I) does a binary search for the element X + % in the array A. If there is an element with that value in the array, + % it returns its index I. If there is no element with that value in the + % array, it returns an index whose slot contains the highest value in the + % array that is less than X, as measured by the builtin Mercury order + % on terms for approx_binary_search/3, and as measured by the supplied + % ordering for approx_binary_search/4. It will fail only if there is + % no value smaller than X in the array. + % + % The array A must be sorted into ascending order with respect to the + % the builtin Mercury order on terms for approx_binary_search/3, and + % with respect to supplied comparison predicate for approx_binary_search/4. + % + % The array may contain duplicates. If it does, and if either the + % searched-for value or (if that does not exist) the highest value + % smaller than the searched-for value is duplicated, the search will return + % the index of one of the copies, but it is not specified *which* copy's + % index it will return. + % +:- pred approx_binary_search(array(T)::array_ui, + T::in, int::out) is semidet. +:- pred approx_binary_search(comparison_func(T)::in, array(T)::array_ui, + T::in, int::out) is semidet. + + % map(Closure, OldArray, NewArray) applies `Closure' to + % each of the elements of `OldArray' to create `NewArray'. + % +:- pred map(pred(T1, T2), array(T1), array(T2)). +%:- mode map(pred(in, out) is det, array_ui, array_uo) is det. +:- mode map(pred(in, out) is det, in, array_uo) is det. + +:- func map(func(T1) = T2, array(T1)) = array(T2). +%:- mode map(func(in) = out is det, array_ui) = array_uo is det. +:- mode map(func(in) = out is det, in) = array_uo is det. + +:- func array_compare(array(T), array(T)) = comparison_result. +:- mode array_compare(in, in) = uo is det. + + % sort(Array) returns a version of Array sorted into ascending + % order. + % + % This sort is not stable. That is, elements that compare/3 decides are + % equal will appear together in the sorted array, but not necessarily + % in the same order in which they occurred in the input array. This is + % primarily only an issue with types with user-defined equivalence for + % which `equivalent' objects are otherwise distinguishable. + % +:- func sort(array(T)) = array(T). +:- mode sort(array_di) = array_uo is det. + + % array.sort was previously buggy. This symbol provides a way to ensure + % that you are using the fixed version. + % +:- pred array.sort_fix_2014 is det. + + % foldl(Fn, Array, X) is equivalent to + % list.foldl(Fn, to_list(Array), X) + % but more efficient. + % +:- func foldl(func(T1, T2) = T2, array(T1), T2) = T2. +%:- mode foldl(func(in, in) = out is det, array_ui, in) = out is det. +:- mode foldl(func(in, in) = out is det, in, in) = out is det. +%:- mode foldl(func(in, di) = uo is det, array_ui, di) = uo is det. +:- mode foldl(func(in, di) = uo is det, in, di) = uo is det. + + % foldl(Pr, Array, !X) is equivalent to + % list.foldl(Pr, to_list(Array), !X) + % but more efficient. + % +:- pred foldl(pred(T1, T2, T2), array(T1), T2, T2). +:- mode foldl(pred(in, in, out) is det, in, in, out) is det. +:- mode foldl(pred(in, mdi, muo) is det, in, mdi, muo) is det. +:- mode foldl(pred(in, di, uo) is det, in, di, uo) is det. +:- mode foldl(pred(in, in, out) is semidet, in, in, out) is semidet. +:- mode foldl(pred(in, mdi, muo) is semidet, in, mdi, muo) is semidet. +:- mode foldl(pred(in, di, uo) is semidet, in, di, uo) is semidet. + + % foldl2(Pr, Array, !X, !Y) is equivalent to + % list.foldl2(Pr, to_list(Array), !X, !Y) + % but more efficient. + % +:- pred foldl2(pred(T1, T2, T2, T3, T3), array(T1), T2, T2, T3, T3). +:- mode foldl2(pred(in, in, out, in, out) is det, in, in, out, in, out) + is det. +:- mode foldl2(pred(in, in, out, mdi, muo) is det, in, in, out, mdi, muo) + is det. +:- mode foldl2(pred(in, in, out, di, uo) is det, in, in, out, di, uo) + is det. +:- mode foldl2(pred(in, in, out, in, out) is semidet, in, + in, out, in, out) is semidet. +:- mode foldl2(pred(in, in, out, mdi, muo) is semidet, in, + in, out, mdi, muo) is semidet. +:- mode foldl2(pred(in, in, out, di, uo) is semidet, in, + in, out, di, uo) is semidet. + + % As above, but with three accumulators. + % +:- pred foldl3(pred(T1, T2, T2, T3, T3, T4, T4), array(T1), + T2, T2, T3, T3, T4, T4). +:- mode foldl3(pred(in, in, out, in, out, in, out) is det, + in, in, out, in, out, in, out) is det. +:- mode foldl3(pred(in, in, out, in, out, mdi, muo) is det, + in, in, out, in, out, mdi, muo) is det. +:- mode foldl3(pred(in, in, out, in, out, di, uo) is det, + in, in, out, in, out, di, uo) is det. +:- mode foldl3(pred(in, in, out, in, out, in, out) is semidet, + in, in, out, in, out, in, out) is semidet. +:- mode foldl3(pred(in, in, out, in, out, mdi, muo) is semidet, + in, in, out, in, out, mdi, muo) is semidet. +:- mode foldl3(pred(in, in, out, in, out, di, uo) is semidet, + in, in, out, in, out, di, uo) is semidet. + + % As above, but with four accumulators. + % +:- pred foldl4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), array(T1), + T2, T2, T3, T3, T4, T4, T5, T5). +:- mode foldl4(pred(in, in, out, in, out, in, out, in, out) is det, + in, in, out, in, out, in, out, in, out) is det. +:- mode foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is det, + in, in, out, in, out, in, out, mdi, muo) is det. +:- mode foldl4(pred(in, in, out, in, out, in, out, di, uo) is det, + in, in, out, in, out, in, out, di, uo) is det. +:- mode foldl4(pred(in, in, out, in, out, in, out, in, out) is semidet, + in, in, out, in, out, in, out, in, out) is semidet. +:- mode foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode foldl4(pred(in, in, out, in, out, in, out, di, uo) is semidet, + in, in, out, in, out, in, out, di, uo) is semidet. + + % As above, but with five accumulators. + % +:- pred foldl5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), + array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). +:- mode foldl5( + pred(in, in, out, in, out, in, out, in, out, in, out) is det, + in, in, out, in, out, in, out, in, out, in, out) is det. +:- mode foldl5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, + in, in, out, in, out, in, out, in, out, mdi, muo) is det. +:- mode foldl5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, + in, in, out, in, out, in, out, in, out, di, uo) is det. +:- mode foldl5( + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, + in, in, out, in, out, in, out, in, out, in, out) is semidet. +:- mode foldl5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode foldl5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, + in, in, out, in, out, in, out, in, out, di, uo) is semidet. + +%---------------------% + + % foldr(Fn, Array, X) is equivalent to + % list.foldr(Fn, to_list(Array), X) + % but more efficient. + % +:- func foldr(func(T1, T2) = T2, array(T1), T2) = T2. +%:- mode foldr(func(in, in) = out is det, array_ui, in) = out is det. +:- mode foldr(func(in, in) = out is det, in, in) = out is det. +%:- mode foldr(func(in, di) = uo is det, array_ui, di) = uo is det. +:- mode foldr(func(in, di) = uo is det, in, di) = uo is det. + + % foldr(P, Array, !Acc) is equivalent to + % list.foldr(P, to_list(Array), !Acc) + % but more efficient. + % +:- pred foldr(pred(T1, T2, T2), array(T1), T2, T2). +:- mode foldr(pred(in, in, out) is det, in, in, out) is det. +:- mode foldr(pred(in, mdi, muo) is det, in, mdi, muo) is det. +:- mode foldr(pred(in, di, uo) is det, in, di, uo) is det. +:- mode foldr(pred(in, in, out) is semidet, in, in, out) is semidet. +:- mode foldr(pred(in, mdi, muo) is semidet, in, mdi, muo) is semidet. +:- mode foldr(pred(in, di, uo) is semidet, in, di, uo) is semidet. + + % As above, but with two accumulators. + % +:- pred foldr2(pred(T1, T2, T2, T3, T3), array(T1), T2, T2, T3, T3). +:- mode foldr2(pred(in, in, out, in, out) is det, in, in, out, in, out) + is det. +:- mode foldr2(pred(in, in, out, mdi, muo) is det, in, in, out, mdi, muo) + is det. +:- mode foldr2(pred(in, in, out, di, uo) is det, in, in, out, di, uo) + is det. +:- mode foldr2(pred(in, in, out, in, out) is semidet, in, + in, out, in, out) is semidet. +:- mode foldr2(pred(in, in, out, mdi, muo) is semidet, in, + in, out, mdi, muo) is semidet. +:- mode foldr2(pred(in, in, out, di, uo) is semidet, in, + in, out, di, uo) is semidet. + + % As above, but with three accumulators. + % +:- pred foldr3(pred(T1, T2, T2, T3, T3, T4, T4), array(T1), + T2, T2, T3, T3, T4, T4). +:- mode foldr3(pred(in, in, out, in, out, in, out) is det, in, + in, out, in, out, in, out) is det. +:- mode foldr3(pred(in, in, out, in, out, mdi, muo) is det, in, + in, out, in, out, mdi, muo) is det. +:- mode foldr3(pred(in, in, out, in, out, di, uo) is det, in, + in, out, in, out, di, uo) is det. +:- mode foldr3(pred(in, in, out, in, out, in, out) is semidet, in, + in, out, in, out, in, out) is semidet. +:- mode foldr3(pred(in, in, out, in, out, mdi, muo) is semidet, in, + in, out, in, out, mdi, muo) is semidet. +:- mode foldr3(pred(in, in, out, in, out, di, uo) is semidet, in, + in, out, in, out, di, uo) is semidet. + + % As above, but with four accumulators. + % +:- pred foldr4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), array(T1), + T2, T2, T3, T3, T4, T4, T5, T5). +:- mode foldr4(pred(in, in, out, in, out, in, out, in, out) is det, + in, in, out, in, out, in, out, in, out) is det. +:- mode foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is det, + in, in, out, in, out, in, out, mdi, muo) is det. +:- mode foldr4(pred(in, in, out, in, out, in, out, di, uo) is det, + in, in, out, in, out, in, out, di, uo) is det. +:- mode foldr4(pred(in, in, out, in, out, in, out, in, out) is semidet, + in, in, out, in, out, in, out, in, out) is semidet. +:- mode foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode foldr4(pred(in, in, out, in, out, in, out, di, uo) is semidet, + in, in, out, in, out, in, out, di, uo) is semidet. + + % As above, but with five accumulators. + % +:- pred foldr5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), + array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). +:- mode foldr5( + pred(in, in, out, in, out, in, out, in, out, in, out) is det, + in, in, out, in, out, in, out, in, out, in, out) is det. +:- mode foldr5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, + in, in, out, in, out, in, out, in, out, mdi, muo) is det. +:- mode foldr5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, + in, in, out, in, out, in, out, in, out, di, uo) is det. +:- mode foldr5( + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, + in, in, out, in, out, in, out, in, out, in, out) is semidet. +:- mode foldr5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode foldr5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, + in, in, out, in, out, in, out, in, out, di, uo) is semidet. + +%---------------------% + + % foldl_corresponding(P, A, B, !Acc): + % + % Does the same job as foldl, but works on two arrays in parallel. + % Throws an exception if the array arguments differ in size. + % +:- pred foldl_corresponding(pred(T1, T2, T3, T3), array(T1), array(T2), + T3, T3). +:- mode foldl_corresponding(in(pred(in, in, in, out) is det), in, in, + in, out) is det. +:- mode foldl_corresponding(in(pred(in, in, mdi, muo) is det), in, in, + mdi, muo) is det. +:- mode foldl_corresponding(in(pred(in, in, di, uo) is det), in, in, + di, uo) is det. +:- mode foldl_corresponding(in(pred(in, in, in, out) is semidet), in, in, + in, out) is semidet. +:- mode foldl_corresponding(in(pred(in, in, mdi, muo) is semidet), in, in, + mdi, muo) is semidet. +:- mode foldl_corresponding(in(pred(in, in, di, uo) is semidet), in, in, + di, uo) is semidet. + + % As above, but with two accumulators. + % +:- pred foldl2_corresponding(pred(T1, T2, T3, T3, T4, T4), + array(T1), array(T2), T3, T3, T4, T4). +:- mode foldl2_corresponding(in(pred(in, in, in, out, in, out) is det), + in, in, in, out, in, out) is det. +:- mode foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is det), + in, in, in, out, mdi, muo) is det. +:- mode foldl2_corresponding(in(pred(in, in, in, out, di, uo) is det), + in, in, in, out, di, uo) is det. +:- mode foldl2_corresponding(in(pred(in, in, in, out, in, out) is semidet), + in, in, in, out, in, out) is semidet. +:- mode foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is semidet), + in, in, in, out, mdi, muo) is semidet. +:- mode foldl2_corresponding(in(pred(in, in, in, out, di, uo) is semidet), + in, in, in, out, di, uo) is semidet. + +%---------------------% + + % map_foldl(P, A, B, !Acc): + % Invoke P(Aelt, Belt, !Acc) on each element of the A array, + % and construct array B from the resulting values of Belt. + % +:- pred map_foldl(pred(T1, T2, T3, T3), array(T1), array(T2), T3, T3). +:- mode map_foldl(in(pred(in, out, in, out) is det), + in, array_uo, in, out) is det. +:- mode map_foldl(in(pred(in, out, mdi, muo) is det), + in, array_uo, mdi, muo) is det. +:- mode map_foldl(in(pred(in, out, di, uo) is det), + in, array_uo, di, uo) is det. +:- mode map_foldl(in(pred(in, out, in, out) is semidet), + in, array_uo, in, out) is semidet. + +%---------------------% + + % map_corresponding_foldl(P, A, B, C, !Acc): + % + % Given two arrays A and B, invoke P(Aelt, Belt, Celt, !Acc) on + % each corresponding pair of elements Aelt and Belt. Build up the array C + % from the result Celt values. Return C and the final value of the + % accumulator. + % + % Throws an exception if A and B differ in size. + % +:- pred map_corresponding_foldl(pred(T1, T2, T3, T4, T4), + array(T1), array(T2), array(T3), T4, T4). +:- mode map_corresponding_foldl( + in(pred(in, in, out, in, out) is det), + in, in, array_uo, in, out) is det. +:- mode map_corresponding_foldl( + in(pred(in, in, out, mdi, muo) is det), + in, in, array_uo, mdi, muo) is det. +:- mode map_corresponding_foldl( + in(pred(in, in, out, di, uo) is det), + in, in, array_uo, di, uo) is det. +:- mode map_corresponding_foldl( + in(pred(in, in, out, in, out) is semidet), + in, in, array_uo, in, out) is semidet. +:- mode map_corresponding_foldl( + in(pred(in, in, out, mdi, muo) is semidet), + in, in, array_uo, mdi, muo) is semidet. +:- mode map_corresponding_foldl( + in(pred(in, in, out, di, uo) is semidet), + in, in, array_uo, di, uo) is semidet. + +%---------------------% + + % all_true(Pred, Array): + % True iff Pred is true for every element of Array. + % +:- pred all_true(pred(T), array(T)). +%:- mode all_true(in(pred(in) is semidet), array_ui) is semidet. +:- mode all_true(in(pred(in) is semidet), in) is semidet. + + % all_false(Pred, Array): + % True iff Pred is false for every element of Array. + % +:- pred all_false(pred(T), array(T)). +%:- mode all_false(in(pred(in) is semidet), array_ui) is semidet. +:- mode all_false(in(pred(in) is semidet), in) is semidet. + + % append(A, B) = C: + % + % Make C a concatenation of the arrays A and B. + % +:- func append(array(T)::in, array(T)::in) = (array(T)::array_uo) is det. + + % random_permutation(A0, A, RS0, RS) permutes the elements in + % A0 given random seed RS0 and returns the permuted array in A + % and the next random seed in RS. + % +:- pred random_permutation(array(T)::array_di, array(T)::array_uo, + random.supply::mdi, random.supply::muo) is det. + + % Convert an array to a pretty_printer.doc for formatting. + % +:- func array_to_doc(array(T)) = pretty_printer.doc. +:- mode array_to_doc(array_ui) = out is det. + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- implementation. + +% Everything beyond here is not intended as part of the public interface, +% and will not appear in the Mercury Library Reference Manual. + +:- interface. + + % dynamic_cast/2 won't work for arbitrary arrays since array/1 is + % not a ground type (that is, dynamic_cast/2 will work when the + % target type is e.g. array(int), but not when it is array(T)). + % +:- some [T2] pred dynamic_cast_to_array(T1::in, array(T2)::out) is semidet. + +:- implementation. + +:- import_module exception. +:- import_module int. +:- import_module require. +:- import_module string. +:- import_module type_desc. + +% +% Define the array type appropriately for the different targets. +% Note that the definitions here should match what is output by +% mlds_to_c.m, mlds_to_csharp.m, or mlds_to_java.m for mlds.mercury_array_type. +% + + % MR_ArrayPtr is defined in runtime/mercury_types.h. +:- pragma foreign_type("C", array(T), "MR_ArrayPtr") + where equality is array.array_equal, + comparison is array.array_compare. + +:- pragma foreign_type("C#", array(T), "System.Array") + where equality is array.array_equal, + comparison is array.array_compare. + + % We can't use `java.lang.Object []', since we want a generic type + % that is capable of holding any kind of array, including e.g. `int []'. + % Java doesn't have any equivalent of .NET's System.Array class, + % so we just use the universal base `java.lang.Object'. +:- pragma foreign_type("Java", array(T), "/* Array */ java.lang.Object") + where equality is array.array_equal, + comparison is array.array_compare. + + % unify/2 for arrays + % +:- pred array_equal(array(T)::in, array(T)::in) is semidet. +:- pragma terminates(array_equal/2). + +array_equal(Array1, Array2) :- + ( if + array.size(Array1, Size), + array.size(Array2, Size) + then + equal_elements(0, Size, Array1, Array2) + else + fail + ). + +:- pred equal_elements(int, int, array(T), array(T)). +:- mode equal_elements(in, in, in, in) is semidet. + +equal_elements(N, Size, Array1, Array2) :- + ( if N = Size then + true + else + array.unsafe_lookup(Array1, N, Elem), + array.unsafe_lookup(Array2, N, Elem), + N1 = N + 1, + equal_elements(N1, Size, Array1, Array2) + ). + +array_compare(A1, A2) = C :- + array_compare(C, A1, A2). + + % compare/3 for arrays + % +:- pred array_compare(comparison_result::uo, array(T)::in, array(T)::in) + is det. +:- pragma terminates(array_compare/3). + +array_compare(Result, Array1, Array2) :- + array.size(Array1, Size1), + array.size(Array2, Size2), + compare(SizeResult, Size1, Size2), + ( + SizeResult = (=), + compare_elements(0, Size1, Array1, Array2, Result) + ; + ( SizeResult = (<) + ; SizeResult = (>) + ), + Result = SizeResult + ). + +:- pred compare_elements(int::in, int::in, array(T)::in, array(T)::in, + comparison_result::uo) is det. + +compare_elements(N, Size, Array1, Array2, Result) :- + ( if N = Size then + Result = (=) + else + array.unsafe_lookup(Array1, N, Elem1), + array.unsafe_lookup(Array2, N, Elem2), + compare(ElemResult, Elem1, Elem2), + ( + ElemResult = (=), + N1 = N + 1, + compare_elements(N1, Size, Array1, Array2, Result) + ; + ( ElemResult = (<) + ; ElemResult = (>) + ), + Result = ElemResult + ) + ). + +%---------------------------------------------------------------------------% + +:- pred bounds_checks is semidet. +:- pragma inline(bounds_checks/0). + +:- pragma foreign_proc("C", + bounds_checks, + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, no_sharing], +" +#ifdef ML_OMIT_ARRAY_BOUNDS_CHECKS + SUCCESS_INDICATOR = MR_FALSE; +#else + SUCCESS_INDICATOR = MR_TRUE; +#endif +"). + +:- pragma foreign_proc("C#", + bounds_checks, + [will_not_call_mercury, promise_pure, thread_safe], +" +#if ML_OMIT_ARRAY_BOUNDS_CHECKS + SUCCESS_INDICATOR = false; +#else + SUCCESS_INDICATOR = true; +#endif +"). + +:- pragma foreign_proc("Java", + bounds_checks, + [will_not_call_mercury, promise_pure, thread_safe], +" + // never do bounds checking for Java (throw exceptions instead) + SUCCESS_INDICATOR = false; +"). + +%---------------------------------------------------------------------------% + +:- pragma foreign_decl("C", " +#include ""mercury_heap.h"" // for MR_maybe_record_allocation() +#include ""mercury_library_types.h"" // for MR_ArrayPtr + +// We do not yet record term sizes for arrays in term size profiling +// grades. Doing so would require +// +// - modifying ML_alloc_array to allocate an extra word for the size; +// - modifying all the predicates that call ML_alloc_array to compute the +// size of the array (the sum of the sizes of the elements and the size of +// the array itself); +// - modifying all the predicates that update array elements to compute the +// difference between the sizes of the terms being added to and deleted from +// the array, and updating the array size accordingly. + +#define ML_alloc_array(newarray, arraysize, alloc_id) \ + do { \ + MR_Word newarray_word; \ + MR_offset_incr_hp_msg(newarray_word, 0, (arraysize), \ + alloc_id, ""array.array/1""); \ + (newarray) = (MR_ArrayPtr) newarray_word; \ + } while (0) +"). + +:- pragma foreign_decl("C", " +void ML_init_array(MR_ArrayPtr, MR_Integer size, MR_Word item); +"). + +:- pragma foreign_code("C", " +// The caller is responsible for allocating the memory for the array. +// This routine does the job of initializing the already-allocated memory. +void +ML_init_array(MR_ArrayPtr array, MR_Integer size, MR_Word item) +{ + MR_Integer i; + + array->size = size; + for (i = 0; i < size; i++) { + array->elements[i] = item; + } +} +"). + +:- pragma foreign_code("C#", " + +public static System.Array +ML_new_array(int Size, object Item) +{ + System.Array arr; + if (Size == 0) { + return null; + } + if ( + Item is int || Item is uint || Item is sbyte || Item is byte || + Item is short || Item is ushort || Item is long || Item is ulong || + Item is double || Item is char || Item is bool + ) { + arr = System.Array.CreateInstance(Item.GetType(), Size); + } else { + arr = new object[Size]; + } + for (int i = 0; i < Size; i++) { + arr.SetValue(Item, i); + } + return arr; +} + +public static System.Array +ML_unsafe_new_array(int Size, object Item, int IndexToSet) +{ + System.Array arr; + + if ( + Item is int || Item is uint || Item is sbyte || Item is byte || + Item is short || Item is ushort || Item is long || Item is ulong || + Item is double || Item is char || Item is bool + ) { + arr = System.Array.CreateInstance(Item.GetType(), Size); + } else { + arr = new object[Size]; + } + arr.SetValue(Item, IndexToSet); + return arr; +} + +public static System.Array +ML_array_resize(System.Array arr0, int Size, object Item) +{ + if (Size == 0) { + return null; + } + if (arr0 == null) { + return ML_new_array(Size, Item); + } + if (arr0.Length == Size) { + return arr0; + } + + int OldSize = arr0.Length; + System.Array arr; + if (Item is int) { + int[] tmp = (int[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is uint) { + uint[] tmp = (uint[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is sbyte) { + sbyte[] tmp = (sbyte[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is byte) { + byte[] tmp = (byte[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is short) { + short[] tmp = (short[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is ushort) { + ushort[] tmp = (ushort[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is long) { + long[] tmp = (long[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is ulong) { + ulong[] tmp = (ulong[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is double) { + double[] tmp = (double[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is char) { + char[] tmp = (char[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else if (Item is bool) { + bool[] tmp = (bool[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } else { + object[] tmp = (object[]) arr0; + System.Array.Resize(ref tmp, Size); + arr = tmp; + } + for (int i = OldSize; i < Size; i++) { + arr.SetValue(Item, i); + } + return arr; +} + +public static System.Array +ML_shrink_array(System.Array arr, int Size) +{ + if (arr == null) { + return null; + } + + // We need to use Item here to determine the type instead of arr itself + // since both 'arr is int[]' and 'arr is uint[]' evaluate to true; + // similarly for the other integer types. (That behaviour is due to an + // inconsistency between the covariance of value-typed arrays in C# and + // the CLR.) + object Item = arr.GetValue(0); + if (Item is int) { + int[] tmp = (int[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is uint) { + uint[] tmp = (uint[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is sbyte) { + sbyte[] tmp = (sbyte[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is byte) { + byte[] tmp = (byte[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is short) { + short[] tmp = (short[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is ushort) { + ushort[] tmp = (ushort[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is long) { + long[] tmp = (long[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is ulong) { + ulong[] tmp = (ulong[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is double) { + double[] tmp = (double[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is char) { + char[] tmp = (char[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else if (Item is bool) { + bool[] tmp = (bool[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } else { + object[] tmp = (object[]) arr; + System.Array.Resize(ref tmp, Size); + return tmp; + } +} +"). + +:- pragma foreign_code("Java", " +public static Object +ML_new_array(int Size, Object Item, boolean fill) +{ + if (Size == 0) { + return null; + } + if (Item instanceof Integer) { + int[] as = new int[Size]; + if (fill) { + java.util.Arrays.fill(as, (Integer) Item); + } + return as; + } + if (Item instanceof Double) { + double[] as = new double[Size]; + if (fill) { + java.util.Arrays.fill(as, (Double) Item); + } + return as; + } + if (Item instanceof Character) { + char[] as = new char[Size]; + if (fill) { + java.util.Arrays.fill(as, (Character) Item); + } + return as; + } + if (Item instanceof Boolean) { + boolean[] as = new boolean[Size]; + if (fill) { + java.util.Arrays.fill(as, (Boolean) Item); + } + return as; + } + if (Item instanceof Byte) { + byte[] as = new byte[Size]; + if (fill) { + java.util.Arrays.fill(as, (Byte) Item); + } + return as; + } + if (Item instanceof Short) { + short[] as = new short[Size]; + if (fill) { + java.util.Arrays.fill(as, (Short) Item); + } + return as; + } + if (Item instanceof Long) { + long[] as = new long[Size]; + if (fill) { + java.util.Arrays.fill(as, (Long) Item); + } + return as; + } + if (Item instanceof Float) { + float[] as = new float[Size]; + if (fill) { + java.util.Arrays.fill(as, (Float) Item); + } + return as; + } + Object[] as = new Object[Size]; + if (fill) { + java.util.Arrays.fill(as, Item); + } + return as; +} + +public static Object +ML_unsafe_new_array(int Size, Object Item, int IndexToSet) +{ + if (Item instanceof Integer) { + int[] as = new int[Size]; + as[IndexToSet] = (Integer) Item; + return as; + } + if (Item instanceof Double) { + double[] as = new double[Size]; + as[IndexToSet] = (Double) Item; + return as; + } + if (Item instanceof Character) { + char[] as = new char[Size]; + as[IndexToSet] = (Character) Item; + return as; + } + if (Item instanceof Boolean) { + boolean[] as = new boolean[Size]; + as[IndexToSet] = (Boolean) Item; + return as; + } + if (Item instanceof Byte) { + byte[] as = new byte[Size]; + as[IndexToSet] = (Byte) Item; + return as; + } + if (Item instanceof Short) { + short[] as = new short[Size]; + as[IndexToSet] = (Short) Item; + return as; + } + if (Item instanceof Long) { + long[] as = new long[Size]; + as[IndexToSet] = (Long) Item; + return as; + } + if (Item instanceof Float) { + float[] as = new float[Size]; + as[IndexToSet] = (Float) Item; + return as; + } + Object[] as = new Object[Size]; + as[IndexToSet] = Item; + return as; +} + +public static int +ML_array_size(Object Array) +{ + if (Array == null) { + return 0; + } else if (Array instanceof int[]) { + return ((int[]) Array).length; + } else if (Array instanceof double[]) { + return ((double[]) Array).length; + } else if (Array instanceof char[]) { + return ((char[]) Array).length; + } else if (Array instanceof boolean[]) { + return ((boolean[]) Array).length; + } else if (Array instanceof byte[]) { + return ((byte[]) Array).length; + } else if (Array instanceof short[]) { + return ((short[]) Array).length; + } else if (Array instanceof long[]) { + return ((long[]) Array).length; + } else if (Array instanceof float[]) { + return ((float[]) Array).length; + } else { + return ((Object[]) Array).length; + } +} + +public static Object +ML_array_resize(Object Array0, int Size, Object Item) +{ + if (Size == 0) { + return null; + } + if (Array0 == null) { + return ML_new_array(Size, Item, true); + } + if (ML_array_size(Array0) == Size) { + return Array0; + } + if (Array0 instanceof int[]) { + int[] arr0 = (int[]) Array0; + int[] Array = new int[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Integer) Item; + } + return Array; + } + if (Array0 instanceof double[]) { + double[] arr0 = (double[]) Array0; + double[] Array = new double[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Double) Item; + } + return Array; + } + if (Array0 instanceof char[]) { + char[] arr0 = (char[]) Array0; + char[] Array = new char[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Character) Item; + } + return Array; + } + if (Array0 instanceof boolean[]) { + boolean[] arr0 = (boolean[]) Array0; + boolean[] Array = new boolean[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Boolean) Item; + } + return Array; + } + if (Array0 instanceof byte[]) { + byte[] arr0 = (byte[]) Array0; + byte[] Array = new byte[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Byte) Item; + } + return Array; + } + if (Array0 instanceof short[]) { + short[] arr0 = (short[]) Array0; + short[] Array = new short[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Short) Item; + } + return Array; + } + if (Array0 instanceof long[]) { + long[] arr0 = (long[]) Array0; + long[] Array = new long[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Long) Item; + } + return Array; + } + if (Array0 instanceof float[]) { + float[] arr0 = (float[]) Array0; + float[] Array = new float[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = (Float) Item; + } + return Array; + } else { + Object[] arr0 = (Object[]) Array0; + Object[] Array = new Object[Size]; + + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); + for (int i = arr0.length; i < Size; i++) { + Array[i] = Item; + } + return Array; + } +} + +public static Object +ML_array_fill(Object array, int fromIndex, int toIndex, Object Item) +{ + if (array == null) { + return null; + } + + if (array instanceof int[]) { + java.util.Arrays.fill(((int []) array), fromIndex, toIndex, + (Integer) Item); + } else if (array instanceof double[]) { + java.util.Arrays.fill(((double []) array), fromIndex, toIndex, + (Double) Item); + } else if (array instanceof byte[]) { + java.util.Arrays.fill(((byte []) array), fromIndex, toIndex, + (Byte) Item); + } else if (array instanceof short[]) { + java.util.Arrays.fill(((short []) array), fromIndex, toIndex, + (Short) Item); + } else if (array instanceof long[]) { + java.util.Arrays.fill(((long []) array), fromIndex, toIndex, + (Long) Item); + } else if (array instanceof char[]) { + java.util.Arrays.fill(((char []) array), fromIndex, toIndex, + (Character) Item); + } else if (array instanceof boolean[]) { + java.util.Arrays.fill(((boolean []) array), fromIndex, toIndex, + (Boolean) Item); + } else if (array instanceof float[]) { + java.util.Arrays.fill(((float []) array), fromIndex, toIndex, + (Float) Item); + } else { + java.util.Arrays.fill(((Object []) array), fromIndex, toIndex, Item); + } + return array; +} +"). + +init(N, X) = A :- + array.init(N, X, A). + +init(Size, Item, Array) :- + ( if Size < 0 then + unexpected($pred, "negative size") + else + array.init_2(Size, Item, Array) + ). + +:- pred init_2(int::in, T::in, array(T)::array_uo) is det. + +:- pragma foreign_proc("C", + init_2(Size::in, Item::in, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, + sharing(yes(int, T, array(T)), [ + cel(Item, []) - cel(Array, [T]) + ]) + ], +" + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); + ML_init_array(Array, Size, Item); +"). +:- pragma foreign_proc("C#", + init_2(Size::in, Item::in, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + Array = array.ML_new_array(Size, Item); +"). +:- pragma foreign_proc("Java", + init_2(Size::in, Item::in, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + Array = array.ML_new_array(Size, Item, true); +"). + +make_empty_array = A :- + array.make_empty_array(A). + +:- pragma foreign_proc("C", + make_empty_array(Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, no_sharing], +" + ML_alloc_array(Array, 1, MR_ALLOC_ID); + ML_init_array(Array, 0, 0); +"). +:- pragma foreign_proc("C#", + make_empty_array(Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + // XXX A better solution than using the null pointer to represent + // the empty array would be to create an array of size 0. However, + // we need to determine the element type of the array before we can + // do that. This could be done by examining the RTTI of the array + // type and then using System.Type.GetType(""<mercury type>"") to + // determine it. However constructing the <mercury type> string is + // a non-trivial amount of work. + Array = null; +"). +:- pragma foreign_proc("Java", + make_empty_array(Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + // XXX as per C# + Array = null; +"). + +%---------------------------------------------------------------------------% + +generate(Size, GenFunc) = Array :- + compare(Result, Size, 0), + ( + Result = (<), + unexpected($pred, "negative size") + ; + Result = (=), + make_empty_array(Array) + ; + Result = (>), + FirstElem = GenFunc(0), + Array0 = unsafe_init(Size, FirstElem, 0), + Array = generate_2(1, Size, GenFunc, Array0) + ). + +:- func unsafe_init(int::in, T::in, int::in) = (array(T)::array_uo) is det. +:- pragma foreign_proc("C", + unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo), + [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail, + does_not_affect_liveness], +" + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); + + // In debugging grades, we fill the array with the first element, + // in case the return value of a call to this predicate is examined + // in the debugger. + #if defined(MR_EXEC_TRACE) + ML_init_array(Array, Size, FirstElem); + #else + Array->size = Size; + Array->elements[IndexToSet] = FirstElem; + #endif + +"). +:- pragma foreign_proc("C#", + unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo), + [promise_pure, will_not_call_mercury, thread_safe], +" + Array = array.ML_unsafe_new_array(Size, FirstElem, IndexToSet); +"). +:- pragma foreign_proc("Java", + unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo), + [promise_pure, will_not_call_mercury, thread_safe], +" + Array = array.ML_unsafe_new_array(Size, FirstElem, IndexToSet); +"). + +:- func generate_2(int::in, int::in, (func(int) = T)::in, array(T)::array_di) + = (array(T)::array_uo) is det. + +generate_2(Index, Size, GenFunc, !.Array) = !:Array :- + ( if Index < Size then + Elem = GenFunc(Index), + array.unsafe_set(Index, Elem, !Array), + !:Array = generate_2(Index + 1, Size, GenFunc, !.Array) + else + true + ). + +generate_foldl(Size, GenPred, Array, !Acc) :- + compare(Result, Size, 0), + ( + Result = (<), + unexpected($pred, "negative size") + ; + Result = (=), + make_empty_array(Array) + ; + Result = (>), + GenPred(0, FirstElem, !Acc), + Array0 = unsafe_init(Size, FirstElem, 0), + generate_foldl_2(1, Size, GenPred, Array0, Array, !Acc) + ). + +:- pred generate_foldl_2(int, int, pred(int, T, A, A), + array(T), array(T), A, A). +:- mode generate_foldl_2(in, in, in(pred(in, out, in, out) is det), + array_di, array_uo, in, out) is det. +:- mode generate_foldl_2(in, in, in(pred(in, out, mdi, muo) is det), + array_di, array_uo, mdi, muo) is det. +:- mode generate_foldl_2(in, in, in(pred(in, out, di, uo) is det), + array_di, array_uo, di, uo) is det. +:- mode generate_foldl_2(in, in, in(pred(in, out, in, out) is semidet), + array_di, array_uo, in, out) is semidet. +:- mode generate_foldl_2(in, in, in(pred(in, out, mdi, muo) is semidet), + array_di, array_uo, mdi, muo) is semidet. +:- mode generate_foldl_2(in, in, in(pred(in, out, di, uo) is semidet), + array_di, array_uo, di, uo) is semidet. + +generate_foldl_2(Index, Size, GenPred, !Array, !Acc) :- + ( if Index < Size then + GenPred(Index, Elem, !Acc), + array.unsafe_set(Index, Elem, !Array), + generate_foldl_2(Index + 1, Size, GenPred, !Array, !Acc) + else + true + ). + +%---------------------------------------------------------------------------% + +min(A) = N :- + array.min(A, N). + +:- pragma foreign_proc("C", + min(Array::in, Min::out), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, no_sharing], +" + // Array not used. + Min = 0; +"). + +:- pragma foreign_proc("C#", + min(_Array::in, Min::out), + [will_not_call_mercury, promise_pure, thread_safe], +" + // Array not used. + Min = 0; +"). + + +:- pragma foreign_proc("Java", + min(_Array::in, Min::out), + [will_not_call_mercury, promise_pure, thread_safe], +" + // Array not used. + Min = 0; +"). + +max(A) = N :- + array.max(A, N). + +:- pragma foreign_proc("C", + max(Array::in, Max::out), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, no_sharing], +" + Max = Array->size - 1; +"). +:- pragma foreign_proc("C#", + max(Array::in, Max::out), + [will_not_call_mercury, promise_pure, thread_safe], +" + if (Array != null) { + Max = Array.Length - 1; + } else { + Max = -1; + } +"). + +:- pragma foreign_proc("Java", + max(Array::in, Max::out), + [will_not_call_mercury, promise_pure, thread_safe], +" + if (Array != null) { + Max = array.ML_array_size(Array) - 1; + } else { + Max = -1; + } +"). + +bounds(Array, Min, Max) :- + array.min(Array, Min), + array.max(Array, Max). + +%---------------------------------------------------------------------------% + +size(A) = N :- + array.size(A, N). + +:- pragma foreign_proc("C", + size(Array::in, Max::out), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, no_sharing], +" + Max = Array->size; +"). + +:- pragma foreign_proc("C#", + size(Array::in, Max::out), + [will_not_call_mercury, promise_pure, thread_safe], +" + if (Array != null) { + Max = Array.Length; + } else { + Max = 0; + } +"). + +:- pragma foreign_proc("Java", + size(Array::in, Max::out), + [will_not_call_mercury, promise_pure, thread_safe], +" + Max = jmercury.array.ML_array_size(Array); +"). + +%---------------------------------------------------------------------------% + +in_bounds(Array, Index) :- + array.bounds(Array, Min, Max), + Min =< Index, Index =< Max. + +is_empty(Array) :- + array.size(Array, 0). + +semidet_set(Index, Item, !Array) :- + ( if array.in_bounds(!.Array, Index) then + array.unsafe_set(Index, Item, !Array) + else + fail + ). + +semidet_slow_set(Index, Item, !Array) :- + ( if array.in_bounds(!.Array, Index) then + array.slow_set(Index, Item, !Array) + else + fail + ). + +slow_set(!.Array, N, X) = !:Array :- + array.slow_set(N, X, !Array). + +slow_set(Index, Item, !Array) :- + array.copy(!Array), + array.set(Index, Item, !Array). + +%---------------------------------------------------------------------------% + +elem(Index, Array) = array.lookup(Array, Index). + +unsafe_elem(Index, Array) = Elem :- + array.unsafe_lookup(Array, Index, Elem). + +lookup(Array, N) = X :- + array.lookup(Array, N, X). + +lookup(Array, Index, Item) :- + ( if + bounds_checks, + not array.in_bounds(Array, Index) + then + out_of_bounds_error(Array, Index, "array.lookup") + else + array.unsafe_lookup(Array, Index, Item) + ). + +semidet_lookup(Array, Index, Item) :- + ( if array.in_bounds(Array, Index) then + array.unsafe_lookup(Array, Index, Item) + else + fail + ). + +:- pragma foreign_proc("C", + unsafe_lookup(Array::in, Index::in, Item::out), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, + sharing(yes(array(T), int, T), [ + cel(Array, [T]) - cel(Item, []) + ]) + ], +" + Item = Array->elements[Index]; +"). + +:- pragma foreign_proc("C#", + unsafe_lookup(Array::in, Index::in, Item::out), + [will_not_call_mercury, promise_pure, thread_safe], +"{ + Item = Array.GetValue(Index); +}"). + +:- pragma foreign_proc("Java", + unsafe_lookup(Array::in, Index::in, Item::out), + [will_not_call_mercury, promise_pure, thread_safe], +" + if (Array instanceof int[]) { + Item = ((int[]) Array)[Index]; + } else if (Array instanceof double[]) { + Item = ((double[]) Array)[Index]; + } else if (Array instanceof char[]) { + Item = ((char[]) Array)[Index]; + } else if (Array instanceof boolean[]) { + Item = ((boolean[]) Array)[Index]; + } else if (Array instanceof byte[]) { + Item = ((byte[]) Array)[Index]; + } else if (Array instanceof short[]) { + Item = ((short[]) Array)[Index]; + } else if (Array instanceof long[]) { + Item = ((long[]) Array)[Index]; + } else if (Array instanceof float[]) { + Item = ((float[]) Array)[Index]; + } else { + Item = ((Object[]) Array)[Index]; + } +"). + +%---------------------------------------------------------------------------% + +'elem :='(Index, Array, Value) = array.set(Array, Index, Value). + +set(A1, N, X) = A2 :- + array.set(N, X, A1, A2). + +set(Index, Item, !Array) :- + ( if + bounds_checks, + not array.in_bounds(!.Array, Index) + then + out_of_bounds_error(!.Array, Index, "array.set") + else + array.unsafe_set(Index, Item, !Array) + ). + +'unsafe_elem :='(Index, !.Array, Value) = !:Array :- + array.unsafe_set(Index, Value, !Array). + +:- pragma foreign_proc("C", + unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, + sharing(yes(int, T, array(T), array(T)), [ + cel(Array0, []) - cel(Array, []), + cel(Item, []) - cel(Array, [T]) + ]) + ], +" + Array0->elements[Index] = Item; // destructive update! + Array = Array0; +"). + +:- pragma foreign_proc("C#", + unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +"{ + Array0.SetValue(Item, Index); // destructive update! + Array = Array0; +}"). + +:- pragma foreign_proc("Java", + unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + if (Array0 instanceof int[]) { + ((int[]) Array0)[Index] = (Integer) Item; + } else if (Array0 instanceof double[]) { + ((double[]) Array0)[Index] = (Double) Item; + } else if (Array0 instanceof char[]) { + ((char[]) Array0)[Index] = (Character) Item; + } else if (Array0 instanceof boolean[]) { + ((boolean[]) Array0)[Index] = (Boolean) Item; + } else if (Array0 instanceof byte[]) { + ((byte[]) Array0)[Index] = (Byte) Item; + } else if (Array0 instanceof short[]) { + ((short[]) Array0)[Index] = (Short) Item; + } else if (Array0 instanceof long[]) { + ((long[]) Array0)[Index] = (Long) Item; + } else if (Array0 instanceof float[]) { + ((float[]) Array0)[Index] = (Float) Item; + } else { + ((Object[]) Array0)[Index] = Item; + } + Array = Array0; // destructive update! +"). + +%---------------------------------------------------------------------------% + +% lower bounds other than zero are not supported +% % array.resize takes an array and new lower and upper bounds. +% % the array is expanded or shrunk at each end to make it fit +% % the new bounds. +% :- pred array.resize(array(T), int, int, array(T)). +% :- mode array.resize(in, in, in, out) is det. + +:- pragma foreign_decl("C", " +extern void +ML_resize_array(MR_ArrayPtr new_array, MR_ArrayPtr old_array, + MR_Integer array_size, MR_Word item); +"). + +:- pragma foreign_code("C", " +// The caller is responsible for allocating the storage for the new array. +// This routine does the job of copying the old array elements to the +// new array, initializing any additional elements in the new array, +// and deallocating the old array. +void +ML_resize_array(MR_ArrayPtr array, MR_ArrayPtr old_array, + MR_Integer array_size, MR_Word item) +{ + MR_Integer i; + MR_Integer elements_to_copy; + + elements_to_copy = old_array->size; + if (elements_to_copy > array_size) { + elements_to_copy = array_size; + } + + array->size = array_size; + for (i = 0; i < elements_to_copy; i++) { + array->elements[i] = old_array->elements[i]; + } + for (; i < array_size; i++) { + array->elements[i] = item; + } + + // Since the mode on the old array is `array_di', it is safe to + // deallocate the storage for it. +#ifdef MR_CONSERVATIVE_GC + MR_GC_free_attrib(old_array); +#endif +} +"). + +resize(!.Array, N, X) = !:Array :- + array.resize(N, X, !Array). + +resize(N, X, !Array) :- + ( if N < 0 then + unexpected($pred, "cannot resize to a negative size") + else + do_resize(N, X, !Array) + ). + +:- pred do_resize(int, T, array(T), array(T)). +:- mode do_resize(in, in, array_di, array_uo) is det. + +:- pragma foreign_proc("C", + do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, + sharing(yes(int, T, array(T), array(T)), [ + cel(Array0, []) - cel(Array, []), + cel(Item, []) - cel(Array, [T]) + ]) + ], +" + if ((Array0)->size == Size) { + Array = Array0; + } else { + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); + ML_resize_array(Array, Array0, Size, Item); + } +"). + +:- pragma foreign_proc("C#", + do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + Array = array.ML_array_resize(Array0, Size, Item); +"). + +:- pragma foreign_proc("Java", + do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + Array = jmercury.array.ML_array_resize(Array0, Size, Item); +"). + +%---------------------------------------------------------------------------% + +:- pragma foreign_decl("C", " +extern void +ML_shrink_array(MR_ArrayPtr array, MR_ArrayPtr old_array, + MR_Integer array_size); +"). + +:- pragma foreign_code("C", " +// The caller is responsible for allocating the storage for the new array. +// This routine does the job of copying the old array elements to the +// new array and deallocating the old array. +void +ML_shrink_array(MR_ArrayPtr array, MR_ArrayPtr old_array, + MR_Integer array_size) +{ + MR_Integer i; + + array->size = array_size; + for (i = 0; i < array_size; i++) { + array->elements[i] = old_array->elements[i]; + } + + // Since the mode on the old array is `array_di', it is safe to + // deallocate the storage for it. +#ifdef MR_CONSERVATIVE_GC + MR_GC_free_attrib(old_array); +#endif +} +"). + +shrink(!.Array, N) = !:Array :- + array.shrink(N, !Array). + +shrink(Size, !Array) :- + OldSize = array.size(!.Array), + ( if Size < 0 then + unexpected($pred, "cannot shrink to a negative size") + else if Size > OldSize then + unexpected($pred, "cannot shrink to a larger size") + else if Size = OldSize then + true + else + array.shrink_2(Size, !Array) + ). + +:- pred shrink_2(int::in, array(T)::array_di, array(T)::array_uo) is det. + +:- pragma foreign_proc("C", + shrink_2(Size::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, + sharing(yes(int, array(T), array(T)), [ + cel(Array0, []) - cel(Array, []) + ]) + ], +" + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); + ML_shrink_array(Array, Array0, Size); +"). + +:- pragma foreign_proc("C#", + shrink_2(Size::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + Array = array.ML_shrink_array(Array0, Size); +"). + +:- pragma foreign_proc("Java", + shrink_2(Size::in, Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + if (Array0 == null) { + Array = null; + } else if (Array0 instanceof int[]) { + Array = new int[Size]; + } else if (Array0 instanceof double[]) { + Array = new double[Size]; + } else if (Array0 instanceof byte[]) { + Array = new byte[Size]; + } else if (Array0 instanceof short[]) { + Array = new short[Size]; + } else if (Array0 instanceof long[]) { + Array = new long[Size]; + } else if (Array0 instanceof char[]) { + Array = new char[Size]; + } else if (Array0 instanceof float[]) { + Array = new float[Size]; + } else if (Array0 instanceof boolean[]) { + Array = new boolean[Size]; + } else { + Array = new Object[Size]; + } + + if (Array != null) { + System.arraycopy(Array0, 0, Array, 0, Size); + } +"). + +%---------------------------------------------------------------------------% + +fill(Item, !Array) :- + array.bounds(!.Array, Min, Max), + do_fill_range(Item, Min, Max, !Array). + +fill_range(Item, Lo, Hi, !Array) :- + ( if Lo > Hi then + unexpected($pred, "empty range") + else if not in_bounds(!.Array, Lo) then + arg_out_of_bounds_error(!.Array, "second", "fill_range", Lo) + else if not in_bounds(!.Array, Hi) then + arg_out_of_bounds_error(!.Array, "third", "fill_range", Hi) + else + do_fill_range(Item, Lo, Hi, !Array) + ). + +%---------------------------------------------------------------------------% + +:- pred do_fill_range(T::in, int::in, int::in, + array(T)::array_di, array(T)::array_uo) is det. + +:- pragma foreign_proc("Java", + do_fill_range(Item::in, Lo::in, Hi::in, + Array0::array_di, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + Array = jmercury.array.ML_array_fill(Array0, Lo, Hi + 1, Item); +"). + +do_fill_range(Item, Lo, Hi, !Array) :- + ( if Lo =< Hi then + array.unsafe_set(Lo, Item, !Array), + do_fill_range(Item, Lo + 1, Hi, !Array) + else + true + ). + +%---------------------------------------------------------------------------% + +:- pragma foreign_decl("C", " +extern void +ML_copy_array(MR_ArrayPtr array, MR_ConstArrayPtr old_array); +"). + +:- pragma foreign_code("C", " +// The caller is responsible for allocating the storage for the new array. +// This routine does the job of copying the array elements. +void +ML_copy_array(MR_ArrayPtr array, MR_ConstArrayPtr old_array) +{ + // Any changes to this function will probably also require changes to + // - array.append below, and + // - MR_deep_copy() in runtime/mercury_deep_copy.[ch]. + + MR_Integer i; + MR_Integer array_size; + + array_size = old_array->size; + array->size = array_size; + for (i = 0; i < array_size; i++) { + array->elements[i] = old_array->elements[i]; + } +} +"). + +copy(A1) = A2 :- + array.copy(A1, A2). + +:- pragma foreign_proc("C", + copy(Array0::in, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, + sharing(yes(array(T), array(T)), [ + cel(Array0, [T]) - cel(Array, [T]) + ]) + ], +" + ML_alloc_array(Array, Array0->size + 1, MR_ALLOC_ID); + ML_copy_array(Array, (MR_ConstArrayPtr) Array0); +"). + +:- pragma foreign_proc("C#", + copy(Array0::in, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + Array = (System.Array) Array0.Clone(); +"). + +:- pragma foreign_proc("Java", + copy(Array0::in, Array::array_uo), + [will_not_call_mercury, promise_pure, thread_safe], +" + int Size; + + if (Array0 == null) { + Array = null; + Size = 0; + } else if (Array0 instanceof int[]) { + Size = ((int[]) Array0).length; + Array = new int[Size]; + } else if (Array0 instanceof double[]) { + Size = ((double[]) Array0).length; + Array = new double[Size]; + } else if (Array0 instanceof byte[]) { + Size = ((byte[]) Array0).length; + Array = new byte[Size]; + } else if (Array0 instanceof short[]) { + Size = ((short[]) Array0).length; + Array = new short[Size]; + } else if (Array0 instanceof long[]) { + Size = ((long[]) Array0).length; + Array = new long[Size]; + } else if (Array0 instanceof char[]) { + Size = ((char[]) Array0).length; + Array = new char[Size]; + } else if (Array0 instanceof float[]) { + Size = ((float[]) Array0).length; + Array = new float[Size]; + } else if (Array0 instanceof boolean[]) { + Size = ((boolean[]) Array0).length; + Array = new boolean[Size]; + } else { + Size = ((Object[]) Array0).length; + Array = new Object[Size]; + } + + if (Array != null) { + System.arraycopy(Array0, 0, Array, 0, Size); + } +"). + +%---------------------------------------------------------------------------% + +array(List) = Array :- + array.from_list(List, Array). + +from_list(List) = Array :- + array.from_list(List, Array). + +from_list([], Array) :- + array.make_empty_array(Array). +from_list(List, Array) :- + List = [Head | Tail], + list.length(List, Len), + Array0 = array.unsafe_init(Len, Head, 0), + array.unsafe_insert_items(Tail, 1, Array0, Array). + +%---------------------------------------------------------------------------% + +:- pred unsafe_insert_items(list(T)::in, int::in, + array(T)::array_di, array(T)::array_uo) is det. + +unsafe_insert_items([], _N, !Array). +unsafe_insert_items([Head | Tail], N, !Array) :- + unsafe_set(N, Head, !Array), + unsafe_insert_items(Tail, N + 1, !Array). + +%---------------------------------------------------------------------------% + +from_reverse_list([]) = Array :- + array.make_empty_array(Array). +from_reverse_list(RevList) = Array :- + RevList = [Head | Tail], + list.length(RevList, Len), + Array0 = array.unsafe_init(Len, Head, Len - 1), + unsafe_insert_items_reverse(Tail, Len - 2, Array0, Array). + +:- pred unsafe_insert_items_reverse(list(T)::in, int::in, + array(T)::array_di, array(T)::array_uo) is det. + +unsafe_insert_items_reverse([], _, !Array). +unsafe_insert_items_reverse([Head | Tail], N, !Array) :- + unsafe_set(N, Head, !Array), + unsafe_insert_items_reverse(Tail, N - 1, !Array). + +%---------------------------------------------------------------------------% + +to_list(Array) = List :- + to_list(Array, List). + +to_list(Array, List) :- + ( if is_empty(Array) then + List = [] + else + bounds(Array, Low, High), + fetch_items(Array, Low, High, List) + ). + +%---------------------------------------------------------------------------% + +fetch_items(Array, Low, High) = List :- + fetch_items(Array, Low, High, List). + +fetch_items(Array, Low, High, List) :- + ( if High < Low then + % If High is less than Low, then there cannot be any array indexes + % within the range Low -> High (inclusive). This can happen when + % calling to_list/2 on the empty array, or when iterative over + % consecutive contiguous regions of an array. (For an example of + % the latter, see ip_get_goals_{before,after} and their callers + % in the deep_profiler directory.) + List = [] + else if not in_bounds(Array, Low) then + arg_out_of_bounds_error(Array, "second", "fetch_items", Low) + else if not in_bounds(Array, High) then + arg_out_of_bounds_error(Array, "third", "fetch_items", High) + else + List = do_foldr_func(func(X, Xs) = [X | Xs], Array, [], Low, High) + ). + +%---------------------------------------------------------------------------% + +map(F, A1) = A2 :- + P = (pred(X::in, Y::out) is det :- Y = F(X)), + array.map(P, A1, A2). + +map(Closure, OldArray, NewArray) :- + ( if array.semidet_lookup(OldArray, 0, Elem0) then + array.size(OldArray, Size), + Closure(Elem0, Elem), + NewArray0 = unsafe_init(Size, Elem, 0), + array.map_2(1, Size, Closure, OldArray, NewArray0, NewArray) + else + array.make_empty_array(NewArray) + ). + +:- pred map_2(int::in, int::in, pred(T1, T2)::in(pred(in, out) is det), + array(T1)::in, array(T2)::array_di, array(T2)::array_uo) is det. + +map_2(N, Size, Closure, OldArray, !NewArray) :- + ( if N >= Size then + true + else + array.unsafe_lookup(OldArray, N, OldElem), + Closure(OldElem, NewElem), + array.unsafe_set(N, NewElem, !NewArray), + map_2(N + 1, Size, Closure, OldArray, !NewArray) + ). + +%---------------------------------------------------------------------------% + +swap(I, J, !Array) :- + ( if not in_bounds(!.Array, I) then + arg_out_of_bounds_error(!.Array, "first", "array.swap", I) + else if not in_bounds(!.Array, J) then + arg_out_of_bounds_error(!.Array, "second", "array.swap", J) + else + unsafe_swap(I, J, !Array) + ). + +unsafe_swap(I, J, !Array) :- + array.unsafe_lookup(!.Array, I, IVal), + array.unsafe_lookup(!.Array, J, JVal), + array.unsafe_set(I, JVal, !Array), + array.unsafe_set(J, IVal, !Array). + +%---------------------------------------------------------------------------% + +member(A, X) :- + nondet_int_in_range(array.min(A), array.max(A), N), + array.unsafe_lookup(A, N, X). + +%---------------------------------------------------------------------------% + + % array.sort/1 has type specialised versions for arrays of ints and strings + % on the expectation that these constitute the common case and are hence + % worth providing a fast-path. + % + % Experiments indicate that type specialisation improves the speed of + % array.sort/1 by about 30-40%. + % +:- pragma type_spec(array.sort/1, T = int). +:- pragma type_spec(array.sort/1, T = string). + +sort(A) = samsort_subarray(A, array.min(A), array.max(A)). + +:- pragma no_inline(array.sort_fix_2014/0). + +sort_fix_2014. + +%---------------------------------------------------------------------------% + +binary_search(A, SearchX, I) :- + array.binary_search(ordering, A, SearchX, I). + +binary_search(Cmp, A, SearchX, I) :- + Lo = 0, + Hi = array.size(A) - 1, + binary_search_loop(Cmp, A, SearchX, Lo, Hi, I). + +:- pred binary_search_loop(comparison_func(T)::in, array(T)::array_ui, + T::in, int::in, int::in, int::out) is semidet. + +binary_search_loop(Cmp, A, SearchX, Lo, Hi, I) :- + % loop invariant: if SearchX is anywhere in A[0] .. A[array.size(A)-1], + % then it is in A[Lo] .. A[Hi]. + Lo =< Hi, + % We calculate Mid this way to avoid overflow. + % The right shift by one bit is a fast implementation of division by 2. + Mid = Lo + ((Hi - Lo) `unchecked_right_shift` 1), + array.unsafe_lookup(A, Mid, MidX), + O = Cmp(MidX, SearchX), + ( + O = (>), + binary_search_loop(Cmp, A, SearchX, Lo, Mid - 1, I) + ; + O = (=), + I = Mid + ; + O = (<), + binary_search_loop(Cmp, A, SearchX, Mid + 1, Hi, I) + ). + +%---------------------------------------------------------------------------% + +approx_binary_search(A, SearchX, I) :- + approx_binary_search(ordering, A, SearchX, I). + +approx_binary_search(Cmp, A, SearchX, I) :- + Lo = 0, + Hi = array.size(A) - 1, + approx_binary_search_loop(Cmp, A, SearchX, Lo, Hi, I). + +:- pred approx_binary_search_loop(comparison_func(T)::in, array(T)::array_ui, + T::in, int::in, int::in, int::out) is semidet. + +approx_binary_search_loop(Cmp, A, SearchX, Lo, Hi, I) :- + % loop invariant: if SearchX is anywhere in A[0] .. A[array.size(A)-1], + % then it is in A[Lo] .. A[Hi]. + Lo =< Hi, + % We calculate Mid this way to avoid overflow. + % The right shift by one bit is a fast implementation of division by 2. + Mid = Lo + ((Hi - Lo) `unchecked_right_shift` 1), + array.unsafe_lookup(A, Mid, MidX), + O = Cmp(MidX, SearchX), + ( + O = (>), + approx_binary_search_loop(Cmp, A, SearchX, Lo, Mid - 1, I) + ; + O = (=), + I = Mid + ; + O = (<), + ( if + ( if Mid < Hi then + % We get here only if Mid + 1 cannot exceed Hi, + % so the array access is safe. + array.unsafe_lookup(A, Mid + 1, MidP1X), + (<) = Cmp(SearchX, MidP1X) + else + Mid = Hi + ) + then + I = Mid + else + approx_binary_search_loop(Cmp, A, SearchX, Mid + 1, Hi, I) + ) + ). + +%---------------------------------------------------------------------------% + +append(A, B) = C :- + SizeA = array.size(A), + SizeB = array.size(B), + SizeC = SizeA + SizeB, + ( if + ( if SizeA > 0 then + array.lookup(A, 0, InitElem) + else if SizeB > 0 then + array.lookup(B, 0, InitElem) + else + fail + ) + then + C0 = array.init(SizeC, InitElem), + copy_subarray(A, 0, SizeA - 1, 0, C0, C1), + copy_subarray(B, 0, SizeB - 1, SizeA, C1, C) + else + C = array.make_empty_array + ). + +:- pragma foreign_proc("C", + append(ArrayA::in, ArrayB::in) = (ArrayC::array_uo), + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, + does_not_affect_liveness, + sharing(yes(array(T), array(T), array(T)), [ + cel(ArrayA, [T]) - cel(ArrayC, [T]), + cel(ArrayB, [T]) - cel(ArrayC, [T]) + ]) + ], +" + MR_Integer sizeC; + MR_Integer i; + MR_Integer offset; + + sizeC = ArrayA->size + ArrayB->size; + ML_alloc_array(ArrayC, sizeC + 1, MR_ALLOC_ID); + + ArrayC->size = sizeC; + for (i = 0; i < ArrayA->size; i++) { + ArrayC->elements[i] = ArrayA->elements[i]; + } + + offset = ArrayA->size; + for (i = 0; i < ArrayB->size; i++) { + ArrayC->elements[offset + i] = ArrayB->elements[i]; + } +"). + +%---------------------------------------------------------------------------% + +random_permutation(A0, A, RS0, RS) :- + Lo = array.min(A0), + Hi = array.max(A0), + Sz = array.size(A0), + permutation_2(Lo, Lo, Hi, Sz, A0, A, RS0, RS). + +:- pred permutation_2(int::in, int::in, int::in, int::in, + array(T)::array_di, array(T)::array_uo, + random.supply::mdi, random.supply::muo) is det. + +permutation_2(I, Lo, Hi, Sz, !A, !RS) :- + ( if I > Hi then + true + else + random.random(R, !RS), + J = Lo + (R `rem` Sz), + swap_elems(I, J, !A), + permutation_2(I + 1, Lo, Hi, Sz, !A, !RS) + ). + +:- pred swap_elems(int::in, int::in, array(T)::array_di, array(T)::array_uo) + is det. + +swap_elems(I, J, !A) :- + array.lookup(!.A, I, XI), + array.lookup(!.A, J, XJ), + array.unsafe_set(I, XJ, !A), + array.unsafe_set(J, XI, !A). + +%---------------------------------------------------------------------------% + +foldl(Fn, A, X) = + do_foldl_func(Fn, A, X, array.min(A), array.max(A)). + +:- func do_foldl_func(func(T1, T2) = T2, array(T1), T2, int, int) = T2. +%:- mode do_foldl_func(func(in, in) = out is det, array_ui, in, in, in) +% = out is det. +:- mode do_foldl_func(func(in, in) = out is det, in, in, in, in) = out is det. +%:- mode do_foldl_func(func(in, di) = uo is det, array_ui, di, in, in) +% = uo is det. +:- mode do_foldl_func(func(in, di) = uo is det, in, di, in, in) = uo is det. + +do_foldl_func(Fn, A, X, I, Max) = + ( if Max < I then + X + else + do_foldl_func(Fn, A, Fn(A ^ unsafe_elem(I), X), I + 1, Max) + ). + +%---------------------------------------------------------------------------% + +foldl(P, A, !Acc) :- + do_foldl_pred(P, A, array.min(A), array.max(A), !Acc). + +:- pred do_foldl_pred(pred(T1, T2, T2), array(T1), int, int, T2, T2). +:- mode do_foldl_pred(pred(in, in, out) is det, in, in, in, in, out) is det. +:- mode do_foldl_pred(pred(in, mdi, muo) is det, in, in, in, mdi, muo) is det. +:- mode do_foldl_pred(pred(in, di, uo) is det, in, in, in, di, uo) is det. +:- mode do_foldl_pred(pred(in, in, out) is semidet, in, in, in, in, out) + is semidet. +:- mode do_foldl_pred(pred(in, mdi, muo) is semidet, in, in, in, mdi, muo) + is semidet. +:- mode do_foldl_pred(pred(in, di, uo) is semidet, in, in, in, di, uo) + is semidet. + +do_foldl_pred(P, A, I, Max, !Acc) :- + ( if Max < I then + true + else + P(A ^ unsafe_elem(I), !Acc), + do_foldl_pred(P, A, I + 1, Max, !Acc) + ). + +%---------------------------------------------------------------------------% + +foldl2(P, A, !Acc1, !Acc2) :- + do_foldl2(P, array.min(A), array.max(A), A, !Acc1, !Acc2). + +:- pred do_foldl2(pred(T1, T2, T2, T3, T3), int, int, array(T1), T2, T2, + T3, T3). +:- mode do_foldl2(pred(in, in, out, in, out) is det, in, in, in, in, out, + in, out) is det. +:- mode do_foldl2(pred(in, in, out, mdi, muo) is det, in, in, in, in, out, + mdi, muo) is det. +:- mode do_foldl2(pred(in, in, out, di, uo) is det, in, in, in, in, out, + di, uo) is det. +:- mode do_foldl2(pred(in, in, out, in, out) is semidet, in, in, in, in, out, + in, out) is semidet. +:- mode do_foldl2(pred(in, in, out, mdi, muo) is semidet, in, in, in, in, out, + mdi, muo) is semidet. +:- mode do_foldl2(pred(in, in, out, di, uo) is semidet, in, in, in, in, out, + di, uo) is semidet. + +do_foldl2(P, I, Max, A, !Acc1, !Acc2) :- + ( if Max < I then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2), + do_foldl2(P, I + 1, Max, A, !Acc1, !Acc2) + ). + +%---------------------------------------------------------------------------% + +foldl3(P, A, !Acc1, !Acc2, !Acc3) :- + do_foldl3(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3). + +:- pred do_foldl3(pred(T1, T2, T2, T3, T3, T4, T4), int, int, array(T1), + T2, T2, T3, T3, T4, T4). +:- mode do_foldl3(pred(in, in, out, in, out, in, out) is det, in, in, in, + in, out, in, out, in, out) is det. +:- mode do_foldl3(pred(in, in, out, in, out, mdi, muo) is det, in, in, in, + in, out, in, out, mdi, muo) is det. +:- mode do_foldl3(pred(in, in, out, in, out, di, uo) is det, in, in, in, + in, out, in, out, di, uo) is det. +:- mode do_foldl3(pred(in, in, out, in, out, in, out) is semidet, in, in, in, + in, out, in, out, in, out) is semidet. +:- mode do_foldl3(pred(in, in, out, in, out, mdi, muo) is semidet, in, in, in, + in, out, in, out, mdi, muo) is semidet. +:- mode do_foldl3(pred(in, in, out, in, out, di, uo) is semidet, in, in, in, + in, out, in, out, di, uo) is semidet. + +do_foldl3(P, I, Max, A, !Acc1, !Acc2, !Acc3) :- + ( if Max < I then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3), + do_foldl3(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3) + ). + +%---------------------------------------------------------------------------% + +foldl4(P, A, !Acc1, !Acc2, !Acc3, !Acc4) :- + do_foldl4(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4). + +:- pred do_foldl4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), int, int, + array(T1), T2, T2, T3, T3, T4, T4, T5, T5). +:- mode do_foldl4(pred(in, in, out, in, out, in, out, in, out) is det, in, in, + in, in, out, in, out, in, out, in, out) is det. +:- mode do_foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is det, in, in, + in, in, out, in, out, in, out, mdi, muo) is det. +:- mode do_foldl4(pred(in, in, out, in, out, in, out, di, uo) is det, in, in, + in, in, out, in, out, in, out, di, uo) is det. +:- mode do_foldl4(pred(in, in, out, in, out, in, out, in, out) is semidet, + in, in, in, in, out, in, out, in, out, in, out) is semidet. +:- mode do_foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, in, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode do_foldl4(pred(in, in, out, in, out, in, out, di, uo) is semidet, + in, in, in, in, out, in, out, in, out, di, uo) is semidet. + +do_foldl4(P, I, Max, A, !Acc1, !Acc2, !Acc3, !Acc4) :- + ( if Max < I then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4), + do_foldl4(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3, !Acc4) + ). + +%---------------------------------------------------------------------------% + +foldl5(P, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- + do_foldl5(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4, + !Acc5). + +:- pred do_foldl5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), + int, int, array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). +:- mode do_foldl5( + pred(in, in, out, in, out, in, out, in, out, in, out) is det, + in, in, in, in, out, in, out, in, out, in, out, in, out) is det. +:- mode do_foldl5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is det. +:- mode do_foldl5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, + in, in, in, in, out, in, out, in, out, in, out, di, uo) is det. +:- mode do_foldl5( + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, + in, in, in, in, out, in, out, in, out, in, out, in, out) is semidet. +:- mode do_foldl5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode do_foldl5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, + in, in, in, in, out, in, out, in, out, in, out, di, uo) is semidet. + +do_foldl5(P, I, Max, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- + ( if Max < I then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4, !Acc5), + do_foldl5(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) + ). + +%---------------------------------------------------------------------------% + +foldr(Fn, A, X) = + do_foldr_func(Fn, A, X, array.min(A), array.max(A)). + +:- func do_foldr_func(func(T1, T2) = T2, array(T1), T2, int, int) = T2. +%:- mode do_foldr_func(func(in, in) = out is det, array_ui, in, in, in) +% = out is det. +:- mode do_foldr_func(func(in, in) = out is det, in, in, in, in) = out is det. +%:- mode do_foldr_func(func(in, di) = uo is det, array_ui, di, in, in) +% = uo is det. +:- mode do_foldr_func(func(in, di) = uo is det, in, di, in, in) = uo is det. + +do_foldr_func(Fn, A, X, Min, I) = + ( if I < Min then + X + else + do_foldr_func(Fn, A, Fn(A ^ unsafe_elem(I), X), Min, I - 1) + ). + +%---------------------------------------------------------------------------% + +foldr(P, A, !Acc) :- + do_foldr_pred(P, array.min(A), array.max(A), A, !Acc). + +:- pred do_foldr_pred(pred(T1, T2, T2), int, int, array(T1), T2, T2). +:- mode do_foldr_pred(pred(in, in, out) is det, in, in, in, in, out) is det. +:- mode do_foldr_pred(pred(in, mdi, muo) is det, in, in, in, mdi, muo) is det. +:- mode do_foldr_pred(pred(in, di, uo) is det, in, in, in, di, uo) is det. +:- mode do_foldr_pred(pred(in, in, out) is semidet, in, in, in, in, out) + is semidet. +:- mode do_foldr_pred(pred(in, mdi, muo) is semidet, in, in, in, mdi, muo) + is semidet. +:- mode do_foldr_pred(pred(in, di, uo) is semidet, in, in, in, di, uo) + is semidet. + +do_foldr_pred(P, Min, I, A, !Acc) :- + ( if I < Min then + true + else + P(A ^ unsafe_elem(I), !Acc), + do_foldr_pred(P, Min, I - 1, A, !Acc) + ). + +%---------------------------------------------------------------------------% + +foldr2(P, A, !Acc1, !Acc2) :- + do_foldr2(P, array.min(A), array.max(A), A, !Acc1, !Acc2). + +:- pred do_foldr2(pred(T1, T2, T2, T3, T3), int, int, array(T1), T2, T2, + T3, T3). +:- mode do_foldr2(pred(in, in, out, in, out) is det, in, in, in, in, out, + in, out) is det. +:- mode do_foldr2(pred(in, in, out, mdi, muo) is det, in, in, in, in, out, + mdi, muo) is det. +:- mode do_foldr2(pred(in, in, out, di, uo) is det, in, in, in, in, out, + di, uo) is det. +:- mode do_foldr2(pred(in, in, out, in, out) is semidet, in, in, in, in, out, + in, out) is semidet. +:- mode do_foldr2(pred(in, in, out, mdi, muo) is semidet, in, in, in, in, out, + mdi, muo) is semidet. +:- mode do_foldr2(pred(in, in, out, di, uo) is semidet, in, in, in, in, out, + di, uo) is semidet. + +do_foldr2(P, Min, I, A, !Acc1, !Acc2) :- + ( if I < Min then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2), + do_foldr2(P, Min, I - 1, A, !Acc1, !Acc2) + ). + +%---------------------------------------------------------------------------% + +foldr3(P, A, !Acc1, !Acc2, !Acc3) :- + do_foldr3(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3). + +:- pred do_foldr3(pred(T1, T2, T2, T3, T3, T4, T4), int, int, array(T1), + T2, T2, T3, T3, T4, T4). +:- mode do_foldr3(pred(in, in, out, in, out, in, out) is det, in, in, in, + in, out, in, out, in, out) is det. +:- mode do_foldr3(pred(in, in, out, in, out, mdi, muo) is det, in, in, in, + in, out, in, out, mdi, muo) is det. +:- mode do_foldr3(pred(in, in, out, in, out, di, uo) is det, in, in, in, + in, out, in, out, di, uo) is det. +:- mode do_foldr3(pred(in, in, out, in, out, in, out) is semidet, in, in, in, + in, out, in, out, in, out) is semidet. +:- mode do_foldr3(pred(in, in, out, in, out, mdi, muo) is semidet, in, in, in, + in, out, in, out, mdi, muo) is semidet. +:- mode do_foldr3(pred(in, in, out, in, out, di, uo) is semidet, in, in, in, + in, out, in, out, di, uo) is semidet. + +do_foldr3(P, Min, I, A, !Acc1, !Acc2, !Acc3) :- + ( if I < Min then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3), + do_foldr3(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3) + ). + +%---------------------------------------------------------------------------% + +foldr4(P, A, !Acc1, !Acc2, !Acc3, !Acc4) :- + do_foldr4(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4). + +:- pred do_foldr4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), int, int, + array(T1), T2, T2, T3, T3, T4, T4, T5, T5). +:- mode do_foldr4(pred(in, in, out, in, out, in, out, in, out) is det, in, in, + in, in, out, in, out, in, out, in, out) is det. +:- mode do_foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is det, in, in, + in, in, out, in, out, in, out, mdi, muo) is det. +:- mode do_foldr4(pred(in, in, out, in, out, in, out, di, uo) is det, in, in, + in, in, out, in, out, in, out, di, uo) is det. +:- mode do_foldr4(pred(in, in, out, in, out, in, out, in, out) is semidet, + in, in, in, in, out, in, out, in, out, in, out) is semidet. +:- mode do_foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, in, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode do_foldr4(pred(in, in, out, in, out, in, out, di, uo) is semidet, + in, in, in, in, out, in, out, in, out, di, uo) is semidet. + +do_foldr4(P, Min, I, A, !Acc1, !Acc2, !Acc3, !Acc4) :- + ( if I < Min then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4), + do_foldr4(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3, !Acc4) + ). + +%---------------------------------------------------------------------------% + +foldr5(P, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- + do_foldr5(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4, + !Acc5). + +:- pred do_foldr5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), + int, int, array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). +:- mode do_foldr5( + pred(in, in, out, in, out, in, out, in, out, in, out) is det, + in, in, in, in, out, in, out, in, out, in, out, in, out) is det. +:- mode do_foldr5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is det. +:- mode do_foldr5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, + in, in, in, in, out, in, out, in, out, in, out, di, uo) is det. +:- mode do_foldr5( + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, + in, in, in, in, out, in, out, in, out, in, out, in, out) is semidet. +:- mode do_foldr5( + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. +:- mode do_foldr5( + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, + in, in, in, in, out, in, out, in, out, in, out, di, uo) is semidet. + +do_foldr5(P, Min, I, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- + ( if I < Min then + true + else + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4, !Acc5), + do_foldr5(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) + ). + +%---------------------------------------------------------------------------% + +foldl_corresponding(P, A, B, !Acc) :- + MaxA = array.max(A), + MaxB = array.max(B), + ( if MaxA = MaxB then + do_foldl_corresponding(P, 0, MaxA, A, B, !Acc) + else + unexpected($pred, "mismatched array sizes") + ). + +:- pred do_foldl_corresponding(pred(T1, T2, T3, T3), int, int, + array(T1), array(T2), T3, T3). +:- mode do_foldl_corresponding(in(pred(in, in, in, out) is det), in, in, + in, in, in, out) is det. +:- mode do_foldl_corresponding(in(pred(in, in, mdi, muo) is det), in, in, + in, in, mdi, muo) is det. +:- mode do_foldl_corresponding(in(pred(in, in, di, uo) is det), in, in, + in, in, di, uo) is det. +:- mode do_foldl_corresponding(in(pred(in, in, in, out) is semidet), in, in, + in, in, in, out) is semidet. +:- mode do_foldl_corresponding(in(pred(in, in, mdi, muo) is semidet), in, in, + in, in, mdi, muo) is semidet. +:- mode do_foldl_corresponding(in(pred(in, in, di, uo) is semidet), in, in, + in, in, di, uo) is semidet. + +do_foldl_corresponding(P, I, Max, A, B, !Acc) :- + ( if Max < I then + true + else + P(A ^ unsafe_elem(I), B ^ unsafe_elem(I), !Acc), + do_foldl_corresponding(P, I + 1, Max, A, B, !Acc) + ). + +foldl2_corresponding(P, A, B, !Acc1, !Acc2) :- + MaxA = array.max(A), + MaxB = array.max(B), + ( if MaxA = MaxB then + do_foldl2_corresponding(P, 0, MaxA, A, B, !Acc1, !Acc2) + else + unexpected($pred, "mismatched array sizes") + ). + +:- pred do_foldl2_corresponding(pred(T1, T2, T3, T3, T4, T4), int, int, + array(T1), array(T2), T3, T3, T4, T4). +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, in, out) is det), + in, in, in, in, in, out, in, out) is det. +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is det), + in, in, in, in, in, out, mdi, muo) is det. +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, di, uo) is det), + in, in, in, in, in, out, di, uo) is det. +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, in, out) is semidet), + in, in, in, in, in, out, in, out) is semidet. +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is semidet), + in, in, in, in, in, out, mdi, muo) is semidet. +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, di, uo) is semidet), + in, in, in, in, in, out, di, uo) is semidet. + +do_foldl2_corresponding(P, I, Max, A, B, !Acc1, !Acc2) :- + ( if Max < I then + true + else + P(A ^ unsafe_elem(I), B ^ unsafe_elem(I), !Acc1, !Acc2), + do_foldl2_corresponding(P, I + 1, Max, A, B, !Acc1, !Acc2) + ). + +%---------------------------------------------------------------------------% + +map_foldl(P, A, B, !Acc) :- + N = array.size(A), + ( if N =< 0 then + B = array.make_empty_array + else + array.unsafe_lookup(A, 0, X), + P(X, Y, !Acc), + B1 = unsafe_init(N, Y, 0), + map_foldl_2(P, 1, A, B1, B, !Acc) + ). + +:- pred map_foldl_2(pred(T1, T2, T3, T3), + int, array(T1), array(T2), array(T2), T3, T3). +:- mode map_foldl_2(in(pred(in, out, in, out) is det), + in, in, array_di, array_uo, in, out) is det. +:- mode map_foldl_2(in(pred(in, out, mdi, muo) is det), + in, in, array_di, array_uo, mdi, muo) is det. +:- mode map_foldl_2(in(pred(in, out, di, uo) is det), + in, in, array_di, array_uo, di, uo) is det. +:- mode map_foldl_2(in(pred(in, out, in, out) is semidet), + in, in, array_di, array_uo, in, out) is semidet. + +map_foldl_2(P, I, A, !B, !Acc) :- + ( if I < array.size(A) then + array.unsafe_lookup(A, I, X), + P(X, Y, !Acc), + array.unsafe_set(I, Y, !B), + map_foldl_2(P, I + 1, A, !B, !Acc) + else + true + ). + +%---------------------------------------------------------------------------% + +map_corresponding_foldl(P, A, B, C, !Acc) :- + SizeA = array.size(A), + SizeB = array.size(B), + ( if SizeA \= SizeB then + unexpected($pred, "mismatched array sizes") + else if SizeA =< 0 then + C = array.make_empty_array + else + array.unsafe_lookup(A, 0, X), + array.unsafe_lookup(B, 0, Y), + P(X, Y, Z, !Acc), + C1 = unsafe_init(SizeA, Z, 0), + map_corresponding_foldl_2(P, 1, SizeA, A, B, C1, C, !Acc) + ). + +:- pred map_corresponding_foldl_2(pred(T1, T2, T3, T4, T4), + int, int, array(T1), array(T2), array(T3), array(T3), T4, T4). +:- mode map_corresponding_foldl_2( + in(pred(in, in, out, in, out) is det), + in, in, in, in, array_di, array_uo, in, out) is det. +:- mode map_corresponding_foldl_2( + in(pred(in, in, out, mdi, muo) is det), + in, in, in, in, array_di, array_uo, mdi, muo) is det. +:- mode map_corresponding_foldl_2( + in(pred(in, in, out, di, uo) is det), + in, in, in, in, array_di, array_uo, di, uo) is det. +:- mode map_corresponding_foldl_2( + in(pred(in, in, out, in, out) is semidet), + in, in, in, in, array_di, array_uo, in, out) is semidet. +:- mode map_corresponding_foldl_2( + in(pred(in, in, out, mdi, muo) is semidet), + in, in, in, in, array_di, array_uo, mdi, muo) is semidet. +:- mode map_corresponding_foldl_2( + in(pred(in, in, out, di, uo) is semidet), + in, in, in, in, array_di, array_uo, di, uo) is semidet. + +map_corresponding_foldl_2(P, I, N, A, B, !C, !Acc) :- + ( if I < N then + array.unsafe_lookup(A, I, X), + array.unsafe_lookup(B, I, Y), + P(X, Y, Z, !Acc), + array.unsafe_set(I, Z, !C), + map_corresponding_foldl_2(P, I + 1, N, A, B, !C, !Acc) + else + true + ). + +%---------------------------------------------------------------------------% + +all_true(Pred, Array) :- + do_all_true(Pred, array.min(Array), array.max(Array), Array). + +:- pred do_all_true(pred(T), int, int, array(T)). +%:- mode do_all_true(in(pred(in) is semidet), in, in, array_ui) is semidet. +:- mode do_all_true(in(pred(in) is semidet), in, in, in) is semidet. + +do_all_true(Pred, I, UB, Array) :- + ( if I =< UB then + array.unsafe_lookup(Array, I, Elem), + Pred(Elem), + do_all_true(Pred, I + 1, UB, Array) + else + true + ). + +all_false(Pred, Array) :- + do_all_false(Pred, array.min(Array), array.max(Array), Array). + +:- pred do_all_false(pred(T), int, int, array(T)). +%:- mode do_all_false(in(pred(in) is semidet), in, in, array_ui) is semidet. +:- mode do_all_false(in(pred(in) is semidet), in, in, in) is semidet. + +do_all_false(Pred, I, UB, Array) :- + ( if I =< UB then + array.unsafe_lookup(Array, I, Elem), + not Pred(Elem), + do_all_false(Pred, I + 1, UB, Array) + else + true + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % SAMsort (smooth applicative merge) invented by R.A. O'Keefe. + % + % SAMsort is a mergesort variant that works by identifying contiguous + % monotonic sequences and merging them, thereby taking advantage of + % any existing order in the input sequence. + % +:- func samsort_subarray(array(T)::array_di, int::in, int::in) = + (array(T)::array_uo) is det. + +:- pragma type_spec(samsort_subarray/3, T = int). +:- pragma type_spec(samsort_subarray/3, T = string). + +samsort_subarray(A0, Lo, Hi) = A :- + samsort_up(0, array.copy(A0), A, A0, _, Lo, Hi, Lo). + + % samsort_up(N, A0, A, B0, B, Lo, Hi, I): + % + % Precondition: + % We are N levels from the bottom (leaf nodes) of the tree. + % A0 is sorted from Lo .. I - 1. + % A0 and B0 are identical from I .. Hi. + % Postcondition: + % A is sorted from Lo .. Hi. + % +:- pred samsort_up(int::in, array(T)::array_di, array(T)::array_uo, + array(T)::array_di, array(T)::array_uo, int::in, int::in, int::in) is det. + +:- pragma type_spec(samsort_up/8, T = int). +:- pragma type_spec(samsort_up/8, T = string). + +samsort_up(N, A0, A, B0, B, Lo, Hi, I) :- + trace [compile_time(flag("array_sort"))] ( + verify_sorted(A0, Lo, I - 1), + verify_identical(A0, B0, I, Hi) + ), + ( if I > Hi then + A = A0, + B = B0 + % A is sorted from Lo .. Hi. + else if N > 0 then + % B0 and A0 are identical from I .. Hi. + samsort_down(N - 1, B0, B1, A0, A1, I, Hi, J), + % A1 is sorted from I .. J - 1. + % B1 and A1 are identical from J .. Hi. + + merge_subarrays(A1, Lo, I - 1, I, J - 1, Lo, B1, B2), + A2 = A1, + + % B2 is sorted from Lo .. J - 1. + % B2 and A2 are identical from J .. Hi. + samsort_up(N + 1, B2, B3, A2, A3, Lo, Hi, J), + % B3 is sorted from Lo .. Hi. + + A = B3, + B = A3 + % A is sorted from Lo .. Hi. + else + % N = 0, I = Lo + copy_run_ascending(A0, B0, B1, Lo, Hi, J), + + % B1 is sorted from Lo .. J - 1. + % B1 and A0 are identical from J .. Hi. + samsort_up(N + 1, B1, B2, A0, A2, Lo, Hi, J), + % B2 is sorted from Lo .. Hi. + + A = B2, + B = A2 + % A is sorted from Lo .. Hi. + ), + trace [compile_time(flag("array_sort"))] ( + verify_sorted(A, Lo, Hi) + ). + + % samsort_down(N, A0, A, B0, B, Lo, Hi, I): + % + % Precondition: + % We are N levels from the bottom (leaf nodes) of the tree. + % A0 and B0 are identical from Lo .. Hi. + % Postcondition: + % B is sorted from Lo .. I - 1. + % A and B are identical from I .. Hi. + % +:- pred samsort_down(int::in, array(T)::array_di, array(T)::array_uo, + array(T)::array_di, array(T)::array_uo, int::in, int::in, int::out) is det. + +:- pragma type_spec(samsort_down/8, T = int). +:- pragma type_spec(samsort_down/8, T = string). + +samsort_down(N, A0, A, B0, B, Lo, Hi, I) :- + trace [compile_time(flag("array_sort"))] ( + verify_identical(A0, B0, Lo, Hi) + ), + ( if Lo > Hi then + A = A0, + B = B0, + I = Lo + % B is sorted from Lo .. I - 1. + else if N > 0 then + samsort_down(N - 1, B0, B1, A0, A1, Lo, Hi, J), + samsort_down(N - 1, B1, B2, A1, A2, J, Hi, I), + % A2 is sorted from Lo .. J - 1. + % A2 is sorted from J .. I - 1. + A = A2, + merge_subarrays(A2, Lo, J - 1, J, I - 1, Lo, B2, B) + % B is sorted from Lo .. I - 1. + else + A = A0, + copy_run_ascending(A0, B0, B, Lo, Hi, I) + % B is sorted from Lo .. I - 1. + ), + trace [compile_time(flag("array_sort"))] ( + verify_sorted(B, Lo, I - 1), + verify_identical(A, B, I, Hi) + ). + +:- pred verify_sorted(array(T)::array_ui, int::in, int::in) is det. + +verify_sorted(A, Lo, Hi) :- + ( if Lo >= Hi then + true + else if compare((<), A ^ elem(Lo + 1), A ^ elem(Lo)) then + unexpected($pred, "array range not sorted") + else + verify_sorted(A, Lo + 1, Hi) + ). + +:- pred verify_identical(array(T)::array_ui, array(T)::array_ui, + int::in, int::in) is det. + +verify_identical(A, B, Lo, Hi) :- + ( if Lo > Hi then + true + else if A ^ elem(Lo) = B ^ elem(Lo) then + verify_identical(A, B, Lo + 1, Hi) + else + unexpected($pred, "array ranges not identical") + ). + +%---------------------------------------------------------------------------% + +:- pred copy_run_ascending(array(T)::array_ui, + array(T)::array_di, array(T)::array_uo, int::in, int::in, int::out) is det. + +:- pragma type_spec(copy_run_ascending/6, T = int). +:- pragma type_spec(copy_run_ascending/6, T = string). + +copy_run_ascending(A, !B, Lo, Hi, I) :- + ( if + Lo < Hi, + compare((>), A ^ elem(Lo), A ^ elem(Lo + 1)) + then + I = search_until((<), A, Lo, Hi), + copy_subarray_reverse(A, Lo, I - 1, I - 1, !B) + else + I = search_until((>), A, Lo, Hi), + copy_subarray(A, Lo, I - 1, Lo, !B) + ). + +%---------------------------------------------------------------------------% + +:- func search_until(comparison_result::in, array(T)::array_ui, + int::in, int::in) = (int::out) is det. + +:- pragma type_spec(search_until/4, T = int). +:- pragma type_spec(search_until/4, T = string). + +search_until(R, A, Lo, Hi) = + ( if + Lo < Hi, + not compare(R, A ^ elem(Lo), A ^ elem(Lo + 1)) + then + search_until(R, A, Lo + 1, Hi) + else + Lo + 1 + ). + +%---------------------------------------------------------------------------% + + % Assigns the subarray A[Lo..Hi] to B[InitI..Final], where InitI + % is the initial value of I, and FinalI = InitI + (Ho - Lo + 1). + % In this version, I is ascending, so B[InitI] gets A[Lo] + % +:- pred copy_subarray(array(T)::array_ui, int::in, int::in, int::in, + array(T)::array_di, array(T)::array_uo) is det. + +:- pragma type_spec(copy_subarray/6, T = int). +:- pragma type_spec(copy_subarray/6, T = string). + +copy_subarray(A, Lo, Hi, I, !B) :- + ( if Lo =< Hi then + array.lookup(A, Lo, X), + % XXX Would it be safe to replace this with array.unsafe_set? + array.set(I, X, !B), + copy_subarray(A, Lo + 1, Hi, I + 1, !B) + else + true + ). + + % Assigns the subarray A[Lo..Hi] to B[InitI..Final], where InitI + % is the initial value of I, and FinalI = InitI - (Ho - Lo + 1). + % In this version, I is descending, so B[InitI] gets A[Hi]. + % +:- pred copy_subarray_reverse(array(T)::array_ui, int::in, int::in, int::in, + array(T)::array_di, array(T)::array_uo) is det. + +:- pragma type_spec(copy_subarray_reverse/6, T = int). +:- pragma type_spec(copy_subarray_reverse/6, T = string). + +copy_subarray_reverse(A, Lo, Hi, I, !B) :- + ( if Lo =< Hi then + array.lookup(A, Lo, X), + % XXX Would it be safe to replace this with array.unsafe_set? + array.set(I, X, !B), + copy_subarray_reverse(A, Lo + 1, Hi, I - 1, !B) + else + true + ). + +%---------------------------------------------------------------------------% + + % merges the two sorted consecutive subarrays Lo1 .. Hi1 and Lo2 .. Hi2 + % from A into the subarray starting at I in B. + % +:- pred merge_subarrays(array(T)::array_ui, + int::in, int::in, int::in, int::in, int::in, + array(T)::array_di, array(T)::array_uo) is det. + +:- pragma type_spec(merge_subarrays/8, T = int). +:- pragma type_spec(merge_subarrays/8, T = string). + +merge_subarrays(A, Lo1, Hi1, Lo2, Hi2, I, !B) :- + ( if Lo1 > Hi1 then + copy_subarray(A, Lo2, Hi2, I, !B) + else if Lo2 > Hi2 then + copy_subarray(A, Lo1, Hi1, I, !B) + else + array.lookup(A, Lo1, X1), + array.lookup(A, Lo2, X2), + compare(R, X1, X2), + ( + R = (<), + array.set(I, X1, !B), + merge_subarrays(A, Lo1 + 1, Hi1, Lo2, Hi2, I + 1, !B) + ; + R = (=), + array.set(I, X1, !B), + merge_subarrays(A, Lo1 + 1, Hi1, Lo2, Hi2, I + 1, !B) + ; + R = (>), + array.set(I, X2, !B), + merge_subarrays(A, Lo1, Hi1, Lo2 + 1, Hi2, I + 1, !B) + ) + ). + +%---------------------------------------------------------------------------% + + % Throw an exception indicating an array bounds error. + % +:- pred out_of_bounds_error(array(T), int, string). +%:- mode out_of_bounds_error(array_ui, in, in) is erroneous. +:- mode out_of_bounds_error(in, in, in) is erroneous. + +out_of_bounds_error(Array, Index, PredName) :- + % Note: we deliberately do not include the array element type name in the + % error message here, for performance reasons: using the type name could + % prevent the compiler from optimizing away the construction of the + % type_info in the caller, because it would prevent unused argument + % elimination. Performance is important here, because array.set and + % array.lookup are likely to be used in the inner loops of + % performance-critical applications. + array.bounds(Array, Min, Max), + string.format("%s: index %d not in range [%d, %d]", + [s(PredName), i(Index), i(Min), i(Max)], Msg), + throw(array.index_out_of_bounds(Msg)). + + % Like the above, but for use in cases where the are multiple arguments + % that correspond to array indices. + % +:- pred arg_out_of_bounds_error(array(T), string, string, int). +:- mode arg_out_of_bounds_error(in, in, in, in) is erroneous. + +arg_out_of_bounds_error(Array, ArgPosn, PredName, Index) :- + array.bounds(Array, Min, Max), + string.format("%s argument of %s: index %d not in range [%d, %d]", + [s(ArgPosn), s(PredName), i(Index), i(Min), i(Max)], Msg), + throw(array.index_out_of_bounds(Msg)). + +%---------------------------------------------------------------------------% + +det_least_index(A) = Index :- + ( if array.is_empty(A) then + unexpected($pred, "empty array") + else + Index = array.min(A) + ). + +semidet_least_index(A) = Index :- + ( if array.is_empty(A) then + fail + else + Index = array.min(A) + ). + +%---------------------------------------------------------------------------% + +det_greatest_index(A) = Index :- + ( if array.is_empty(A) then + unexpected($pred, "empty array") + else + Index = array.max(A) + ). + +semidet_greatest_index(A) = Index :- + ( if array.is_empty(A) then + fail + else + Index = array.max(A) + ). + +%---------------------------------------------------------------------------% + +array_to_doc(A) = + indent([str("array(["), array_to_doc_2(0, A), str("])")]). + +:- func array_to_doc_2(int, array(T)) = doc. + +array_to_doc_2(I, A) = + ( if I > array.max(A) then + str("") + else + docs([ + format_arg(format(A ^ elem(I))), + ( if I = array.max(A) then str("") else group([str(", "), nl]) ), + format_susp((func) = array_to_doc_2(I + 1, A)) + ]) + ). + +%---------------------------------------------------------------------------% + +dynamic_cast_to_array(X, A) :- + % If X is an array then it has a type with one type argument. + [ArgTypeDesc] = type_args(type_of(X)), + + % Convert ArgTypeDesc to a type variable ArgType. + (_ `with_type` ArgType) `has_type` ArgTypeDesc, + + % Constrain the type of A to be array(ArgType) and do the cast. + dynamic_cast(X, A `with_type` array(ArgType)). + +%---------------------------------------------------------------------------% +:- end_module array. +%---------------------------------------------------------------------------% -- 2.26.3 ^ permalink raw reply related [flat|nested] 27+ messages in thread
[parent not found: <70503251-f8ea-9006-b7e7-b13b93bb71de@gmail.com>]
* bug#47408: Fwd: bug#47408: Etags support for Mercury [v0.4] [not found] ` <70503251-f8ea-9006-b7e7-b13b93bb71de@gmail.com> @ 2021-05-15 8:31 ` Eli Zaretskii [not found] ` <53162dfb-0715-3077-78d1-3a8340943f2f@gmail.com> 0 siblings, 1 reply; 27+ messages in thread From: Eli Zaretskii @ 2021-05-15 8:31 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 > From: fabrice nicol <fabrnicol@gmail.com> > Date: Wed, 12 May 2021 18:35:43 +0200 > > Yes, I did post a patch with all your review comments complied with, or so I think, on March 29. > There is just one review comment of yours that I did not follow: upon closer examination, it is unnecessary > and may be misleading to specify "Mercury-specific behavior for --no-defines". See below comments in my > March 29 email. > Note that in this default case, etags support for Prolog works the same way, so there is no good reason to > make a special case for Mercury. I'm confused. First, you originally said that this option had to do something special for Mercury. Moreover, the patch you sent now still says: +** Etags support for the Mercury programming language (https://mercurylang.org). +** Etags command line option --declarations now has Mercury-specific behavior. +All Mercury declarations are tagged by default. +For compatibility with Prolog etags support, predicates and functions appearing +first in clauses will also be tagged if etags is run with '--declarations'. So there still is some Mercury-specific behavior here. What am I missing? > > Patch is file 0001-Add... .patch, joined again. > > I hope this works. > Best, > Fabrice > > Le mer. 12 mai 2021 à 5:47 PM, Eli Zaretskii <eliz@gnu.org> a écrit : > > From: fabrice nicol <fabrnicol@gmail.com> > > Date: Wed, 12 May 2021 17:16:56 +0200 > > > > All papers have been signed and approved by copyright clerks. > > > > Do I have anything to do now, like issue a pull request in the git repository? Or just sit back and wait for the > > procedure to unroll? > > An updated patch with all the review comments taken care of would be > nice. I don't think we had such a patch before the paperwork started, > did we? > > -------- Message transféré -------- > > Sujet : bug#47408: Etags support for Mercury [v0.4] > Date : Mon, 29 Mar 2021 13:53:26 +0200 > De : fabrice nicol <fabrnicol@gmail.com> > Pour : 47408@debbugs.gnu.org > > Attached is the new patch that integrates your indications. > > Please note two points: > > 1. Now that -m/-M have been done with, there is no use specifying any Mercury-specific behavior for > --no-defines. > > Actually the Mercury community consensus is that all declarations should be tagged in any case. > > So --no-defines is just the default behavior of etags run without any option and does not need to be used > explicitly or specifically documented. > > I followed your indications about --declarations. I also added a line to etags.1 about --language=mercury or > --language=objc, should the heuristic test fail to detect the right language. Note, however, that removing > language-specific options comes at a price. The heuristic test has now to be more complex. I had errless > detection results against my test base of 4,000 mercury files and 500 Obj.-C files. This looks satisfactory > but I had to tweak the heuristic test function (test_objc_is_mercury) quite a bit to weed out detection failures. > > I added the ChangeLog, the requested test file (array.m) under test/manual/etags/merc-src and altered the > corresponding Makefile accordingly. > > 2. I removed my added line to speedbar.el, which in the end did not prove very useful. It is located in a > Xemacs compatibility layer that is no longer used by most users. > > Le 28/03/2021 à 18:22, Eli Zaretskii a écrit : > > From: fabrice nicol <fabrnicol@gmail.com> > Date: Sun, 28 Mar 2021 17:49:20 +0200 > > I left this couple of options in (following Francesco Potorti only for long options > --declarations/--no-defines), > for two reasons: > > 1. The ambiguity between Objective C and Mercury > > Both languages having the same file extension .m, it was necessary to add in a heuristic test > function, in the > absence of explicit language identification input from command line. > > Yet all heuristics may fail in rare cases. Tests show a fairly low failure rate on the Mercury > compiler source > code. Less than 0.5 % of .m files are not identified as Mercury files by the test (this should have > been > documented somewhere). File concerned by test failure are some Mercury test files and > documentary test > files with only (or almost only) comments and blank lines. > > While this could be improved by tweaking the heuristic test, it would make it more complex, > bug-prone and > ultimately hard to maintain. > > So -m/-M are useful to deal with these rare files, as they do not rely on the heuristic test function > at all but on > their own semantics, which explicitly identifies Mercury. > > The only alternative I see is to explicitly warn users about adding '-l mercury' to command line > when using > long options (in etags.1 and possibly other docs). > > I think "-l mercury" is indeed the way to tell etags this is a Mercury > source. > > We never had language-specific options in etags, and I don't see a > serious enough reason to introduce them now. I do find it unfortunate > that Mercury uses the same extension as ObjC, but that's water under > the bridge. > > Of course, if the heuristic test could be improved to make it err > less, it would also be good. > > diff --git a/lisp/speedbar.el b/lisp/speedbar.el > index 12e57b1108..63f3cd6ca1 100644 > --- a/lisp/speedbar.el > +++ b/lisp/speedbar.el > @@ -3534,6 +3534,8 @@ speedbar-fetch-etags-parse-list > speedbar-parse-c-or-c++tag) > ("^\\.emacs$\\|.\\(el\\|l\\|lsp\\)\\'" . > "def[^i]+\\s-+\\(\\(\\w\\|[-_]\\)+\\)\\s-*\C-?") > + ("^\\.m$\\'" . > + "\\(^:-\\)?\\s-*\\(\\(pred\\|func\\|type\\|instance\\|typeclass\\)+\\s+\\([a-z]+[a-zA-Z0-9_]*\\)+\\)\\s-* > (?^?") > ; ("\\.\\([fF]\\|for\\|FOR\\|77\\|90\\)\\'" . > ; speedbar-parse-fortran77-tag) > ("\\.tex\\'" . speedbar-parse-tex-string) > > What about ObjC here? or are these keywords good for ObjC as well? > > has the following reply: Objective C .m files are not parsed by speedbar.el in current repository > code, so the > added feature does not break anything. Issues will only arise if/when Emacs maintainers for > Objective C > support decide on adding this file format to the speedbar parser. It would be premature (and > out-of-place) > for me to settle this on my own. Should this move happen, the heuristics used in etags.c (function > test_objc_is_mercury) could then be ported to elisp code. > > OK, so please add there a comment to say that .m is also Objective C, > but Speedbar doesn't support it yet. > > Thanks. > > [2:text/x-patch Hide Save:0001-Add-etags-support-for-Mercury-v0.4.patch (139kB)] > > >From a0781212917457d3569de941c80364523a422c08 Mon Sep 17 00:00:00 2001 > From: Fabrice Nicol <fabrnicol@gmail.com> > Date: Mon, 29 Mar 2021 10:55:27 +0200 > Subject: [PATCH] Add etags support for Mercury [v0.4] > > --- > doc/man/etags.1 | 23 +- > etc/NEWS | 7 + > lib-src/ChangeLog | 14 + > lib-src/etags.c | 490 +++- > test/manual/etags/Makefile | 3 +- > test/manual/etags/merc-src/array.m | 3416 ++++++++++++++++++++++++++++ > 6 files changed, 3940 insertions(+), 13 deletions(-) > create mode 100644 lib-src/ChangeLog > create mode 100644 test/manual/etags/merc-src/array.m > > diff --git a/doc/man/etags.1 b/doc/man/etags.1 > index c5c15fb182..4a908fc0a0 100644 > --- a/doc/man/etags.1 > +++ b/doc/man/etags.1 > @@ -1,5 +1,5 @@ > .\" See section COPYING for copyright and redistribution information. > -.TH ETAGS 1 "2019-06-24" "GNU Tools" "GNU" > +.TH ETAGS 1 "2021-03-30" "GNU Tools" "GNU" > .de BP > .sp > .ti -.2i > @@ -50,9 +50,9 @@ format understood by > .BR vi ( 1 )\c > \&. Both forms of the program understand > the syntax of C, Objective C, C++, Java, Fortran, Ada, Cobol, Erlang, > -Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Pascal, Perl, > -Ruby, PHP, PostScript, Python, Prolog, Scheme and > -most assembler\-like syntaxes. > +Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Mercury, Pascal, > +Perl, Ruby, PHP, PostScript, Python, Prolog, Scheme and most assembler\-like > +syntaxes. > Both forms read the files specified on the command line, and write a tag > table (defaults: \fBTAGS\fP for \fBetags\fP, \fBtags\fP for > \fBctags\fP) in the current working directory. > @@ -91,6 +91,9 @@ Only \fBctags\fP accepts this option. > In C and derived languages, create tags for function declarations, > and create tags for extern variables unless \-\-no\-globals is used. > In Lisp, create tags for (defvar foo) declarations. > +In Mercury, declarations start a line with "\|\fB:-\fP\|" and are tagged > +by default. This option also tags predicates or functions in first rules > +of clauses, as in Prolog. > .TP > .B \-D, \-\-no\-defines > Do not create tag entries for C preprocessor constant definitions > @@ -125,10 +128,14 @@ final brace of a function or structure definition in C and C++. > Parse the following files according to the given language. More than > one such options may be intermixed with filenames. Use \fB\-\-help\fP > to get a list of the available languages and their default filename > -extensions. The "auto" language can be used to restore automatic > -detection of language based on the file name. The "none" > -language may be used to disable language parsing altogether; only > -regexp matching is done in this case (see the \fB\-\-regex\fP option). > +extensions. For example, as Mercury and Objective-C have same > +filename extension \fI.m\fP, a test based on contents tries to detect > +the language. If this test fails, \fB\-\-language=\fP\fImercury\fP or > +\fB\-\-language=\fP\fIobjc\fP should be used. > +The "auto" language can be used to restore automatic detection of language > +based on the file name. The "none" language may be used to disable language > +parsing altogether; only regexp matching is done in this case (see the > +\fB\-\-regex\fP option). > .TP > .B \-\-members > Create tag entries for variables that are members of structure-like > diff --git a/etc/NEWS b/etc/NEWS > index 2d66a93474..8afb7c76b4 100644 > --- a/etc/NEWS > +++ b/etc/NEWS > @@ -93,6 +93,13 @@ useful on systems such as FreeBSD which ships only with "etc/termcap". > \f > * Changes in Emacs 28.1 > > ++++ > +** Etags support for the Mercury programming language (https://mercurylang.org). > +** Etags command line option --declarations now has Mercury-specific behavior. > +All Mercury declarations are tagged by default. > +For compatibility with Prolog etags support, predicates and functions appearing > +first in clauses will also be tagged if etags is run with '--declarations'. > + > +++ > ** New command 'font-lock-update', bound to 'C-x x f'. > This command updates the syntax highlighting in this buffer. > diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog > new file mode 100644 > index 0000000000..3ab71a4dab > --- /dev/null > +++ b/lib-src/ChangeLog > @@ -0,0 +1,14 @@ > +Add etags support for Mercury (https://mercurylang.org) > + > +Tag declarations starting lines with ':-'. > +By default, all declarations are tagged. Optionally, first predicate or > +functions in clauses can be tagged as in Prolog support using --declarations > +(Bug#47408). > +* lib-src/etags.c (test_objc_is_mercury, Mercury_functions) > +(mercury_skip_comment, mercury_decl, mercury_pr): > +Implement Mercury support. As Mercury and Objective-C have same file extension > +.m, a heuristic test tries to detect the language. > +If this test fails, --language=mercury should be used. > +* doc/man/etags.1: Document the change. Add Mercury-specific behavior for > +--declarations. This option tags first predicates or functions in clauses in > +addition to declarations. > diff --git a/lib-src/etags.c b/lib-src/etags.c > index b5c18e0e01..a5c5224e63 100644 > --- a/lib-src/etags.c > +++ b/lib-src/etags.c > @@ -142,7 +142,14 @@ Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2021 Free Software > # define CTAGS false > #endif > > -/* Copy to DEST from SRC (containing LEN bytes), and append a NUL byte. */ > +/* Define MERCURY_HEURISTICS_RATIO as it was necessary to disambiguate > + Mercury from Objective C, which have same file extensions .m > + See comments before function test_objc_is_mercury for details. */ > +#ifndef MERCURY_HEURISTICS_RATIO > +# define MERCURY_HEURISTICS_RATIO 0.5 > +#endif > + > +/* COPY to DEST from SRC (containing LEN bytes), and append a NUL byte. */ > static void > memcpyz (void *dest, void const *src, ptrdiff_t len) > { > @@ -359,6 +366,7 @@ #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op))) > static void Lisp_functions (FILE *); > static void Lua_functions (FILE *); > static void Makefile_targets (FILE *); > +static void Mercury_functions (FILE *); > static void Pascal_functions (FILE *); > static void Perl_functions (FILE *); > static void PHP_functions (FILE *); > @@ -378,6 +386,7 @@ #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op))) > static bool nocase_tail (const char *); > static void get_tag (char *, char **); > static void get_lispy_tag (char *); > +static void test_objc_is_mercury(char *, language **); > > static void analyze_regex (char *); > static void free_regexps (void); > @@ -683,10 +692,22 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ > "In makefiles, targets are tags; additionally, variables are tags\n\ > unless you specify '--no-globals'."; > > +/* Mercury and Objective C share the same .m file extensions. */ > +static const char *Mercury_suffixes [] = > + {"m", > + NULL}; > +static const char Mercury_help [] = > + "In Mercury code, tags are all declarations beginning a line with ':-'\n\ > +and optionally Prolog-like definitions (first rule for a predicate or \ > +function).\n\ > +To enable this behavior, run etags using --declarations."; > +static bool with_mercury_definitions = false; > +float mercury_heuristics_ratio = MERCURY_HEURISTICS_RATIO; > + > static const char *Objc_suffixes [] = > - { "lm", /* Objective lex file */ > - "m", /* Objective C file */ > - NULL }; > + { "lm", /* Objective lex file */ > + "m", /* By default, Objective C file will be assumed. */ > + NULL}; > static const char Objc_help [] = > "In Objective C code, tags include Objective C definitions for classes,\n\ > class categories, methods and protocols. Tags for variables and\n\ > @@ -824,7 +845,9 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ > { "lisp", Lisp_help, Lisp_functions, Lisp_suffixes }, > { "lua", Lua_help,Lua_functions,Lua_suffixes,NULL,Lua_interpreters}, > { "makefile", Makefile_help,Makefile_targets,NULL,Makefile_filenames}, > + /* objc listed before mercury as it is a better default for .m extensions. */ > { "objc", Objc_help, plain_C_entries, Objc_suffixes }, > + { "mercury", Mercury_help, Mercury_functions, Mercury_suffixes }, > { "pascal", Pascal_help, Pascal_functions, Pascal_suffixes }, > { "perl",Perl_help,Perl_functions,Perl_suffixes,NULL,Perl_interpreters}, > { "php", PHP_help, PHP_functions, PHP_suffixes }, > @@ -950,6 +973,9 @@ print_help (argument *argbuffer) > puts > ("\tand create tags for extern variables unless --no-globals is used."); > > + puts ("In Mercury, tag both declarations starting a line with ':-' and first\n\ > + predicates or functions in clauses."); > + > if (CTAGS) > puts ("-d, --defines\n\ > Create tag entries for C #define constants and enum constants, too."); > @@ -1775,6 +1801,11 @@ find_entries (FILE *inf) > if (parser == NULL) > { > lang = get_language_from_filename (curfdp->infname, true); > + > + /* Disambiguate file names between Objc and Mercury */ > + if (lang != NULL && strcmp(lang->name, "objc") == 0) > + test_objc_is_mercury(curfdp->infname, &lang); > + > if (lang != NULL && lang->function != NULL) > { > curfdp->lang = lang; > @@ -6019,6 +6050,457 @@ prolog_atom (char *s, size_t pos) > return 0; > } > > +\f > +/* > + * Support for Mercury > + * > + * Assumes that the declarationa starts at column 0. > + * Original code by Sunichirou Sugou (1989) for Prolog. > + * Rewritten by Anders Lindgren (1996) for Prolog. > + * Adapted by Fabrice Nicol (2021) for Mercury. > + * Note: Prolog-support behavior is preserved if > + * --declarations is used, corresponding to > + * with_mercury_definitions=true. > + */ > + > +static ptrdiff_t mercury_pr (char *, char *, ptrdiff_t); > +static void mercury_skip_comment (linebuffer *, FILE *); > +static bool is_mercury_type = false; > +static bool is_mercury_quantifier = false; > +static bool is_mercury_declaration = false; > + > +/* > + * Objective-C and Mercury have identical file extension .m > + * To disambiguate between Objective C and Mercury, parse file > + * with the following heuristics hook: > + * - if line starts with :- choose Mercury unconditionally, > + * - if line starts with #, @, choose Objective-C, > + * - otherwise compute the following ratio: > + * > + * r = (number of lines with :- > + * or % in non-commented parts or . at trimmed EOL) > + * / (number of lines - number of lines starting by any amount > + * of whitespace, optionally followed by comment(s)) > + * > + * Note: strings are neglected in counts. > + * > + * If r > mercury_heuristics_ratio, choose Mercury. > + * Experimental tests show that a possibly optimal default value for > + * this floor value is around 0.5. This is the default value for > + * MERCURY_HEURISTICS_RATIO, defined in the first lines of this file. > + * The closer r to 0.5, the closer the source code to pure Prolog. > + * Idiomatic Mercury is scored either with r = 1.0 or higher. > + * Objective-C is scored with r = 0.0. When this fails, the r-score never > + * rose above 0.1 in Objective-C tests. > + */ > + > +static void > +test_objc_is_mercury (char *this_file, language **lang) > +{ > + if (this_file == NULL) return; > + FILE* fp = fopen (this_file, "r"); > + if (fp == NULL) > + pfatal (this_file); > + > + bool blank_line = false; /* Line starting with any amount of white space > + followed by optional comment(s). */ > + bool commented_line = false; > + bool found_dot = false; > + bool only_space_before = true; > + bool start_of_line = true; > + int c; > + intmax_t lines = 1; > + intmax_t mercury_dots = 0; > + intmax_t percentage_signs = 0; > + intmax_t rule_signs = 0; > + float ratio = 0; > + > + while ((c = fgetc (fp)) != EOF) > + { > + switch (c) > + { > + case '\n': > + if (! blank_line) ++lines; > + blank_line = true; > + commented_line = false; > + start_of_line = true; > + if (found_dot) ++mercury_dots; > + found_dot = false; > + only_space_before = true; > + break; > + case '.': > + found_dot = ! commented_line; > + only_space_before = false; > + break; > + case '%': /* More frequent in Mercury. May be modulo in Obj.-C. */ > + if (! commented_line) > + { > + ++percentage_signs; > + /* Cannot tell if it is a comment or modulo yet for sure. > + Yet works for heuristic purposes. */ > + commented_line = true; > + } > + found_dot = false; > + start_of_line = false; > + only_space_before = false; > + break; > + case '/': > + { > + int d = fgetc(fp); > + found_dot = false; > + only_space_before = false; > + if (! commented_line) > + { > + if (d == '*') > + commented_line = true; > + else > + /* If d == '/', cannot tell if it is an Obj.-C comment: > + may be Mercury integ. division. */ > + blank_line = false; > + } > + } > + FALLTHROUGH; > + case ' ': > + case '\t': > + start_of_line = false; > + break; > + case ':': > + c = fgetc(fp); > + if (start_of_line) > + { > + if (c == '-') > + { > + ratio = 1.0; /* Failsafe, not an operator in Obj.-C. */ > + goto out; > + } > + start_of_line = false; > + } > + else > + { > + /* p :- q. Frequent in Mercury. > + Rare or in quoted exprs in Obj.-C. */ > + if (c == '-' && ! commented_line) > + ++rule_signs; > + } > + blank_line = false; > + found_dot = false; > + only_space_before = false; > + break; > + case '@': > + case '#': > + if (start_of_line || only_space_before) > + { > + ratio = 0.0; > + goto out; > + } > + FALLTHROUGH; > + default: > + start_of_line = false; > + blank_line = false; > + found_dot = false; > + only_space_before = false; > + } > + } > + > + /* Fallback heuristic test. Not failsafe but errless in pratice. */ > + ratio = ((float) rule_signs + percentage_signs + mercury_dots) / lines; > + > + out: > + if (fclose(fp) == EOF) > + pfatal(this_file); > + > + if (ratio > mercury_heuristics_ratio) > + { > + /* Change the language from Objective C to Mercury. */ > + static language lang0 = { "mercury", Mercury_help, Mercury_functions, > + Mercury_suffixes }; > + *lang = &lang0; > + } > +} > + > +static void > +Mercury_functions (FILE *inf) > +{ > + char *cp, *last = NULL; > + ptrdiff_t lastlen = 0, allocated = 0; > + if (declarations) with_mercury_definitions = true; > + > + LOOP_ON_INPUT_LINES (inf, lb, cp) > + { > + if (cp[0] == '\0') /* Empty line. */ > + continue; > + else if (c_isspace (cp[0]) || cp[0] == '%') > + /* A Prolog-type comment or anything other than a declaration. */ > + continue; > + else if (cp[0] == '/' && cp[1] == '*') /* Mercury C-type comment. */ > + mercury_skip_comment (&lb, inf); > + else > + { > + is_mercury_declaration = (cp[0] == ':' && cp[1] == '-'); > + > + if (is_mercury_declaration > + || with_mercury_definitions) > + { > + ptrdiff_t len = mercury_pr (cp, last, lastlen); > + if (0 < len) > + { > + /* Store the declaration to avoid generating duplicate > + tags later. */ > + if (allocated <= len) > + { > + xrnew (last, len + 1, 1); > + allocated = len + 1; > + } > + memcpyz (last, cp, len); > + lastlen = len; > + } > + } > + } > + } > + free (last); > +} > + > +static void > +mercury_skip_comment (linebuffer *plb, FILE *inf) > +{ > + char *cp; > + > + do > + { > + for (cp = plb->buffer; *cp != '\0'; ++cp) > + if (cp[0] == '*' && cp[1] == '/') > + return; > + readline (plb, inf); > + } > + while (perhaps_more_input (inf)); > +} > + > +/* > + * A declaration is added if it matches: > + * <beginning of line>:-<whitespace><Mercury Term><whitespace>( > + * If with_mercury_definitions == true, we also add: > + * <beginning of line><Mercury item><whitespace>( > + * or <beginning of line><Mercury item><whitespace>:- > + * As for Prolog support, different arities and types are not taken into > + * consideration. > + * Item is added to the tags database if it doesn't match the > + * name of the previous declaration. > + * > + * Consume a Mercury declaration. > + * Return the number of bytes consumed, or 0 if there was an error. > + * > + * A Mercury declaration must be one of: > + * :- type > + * :- solver type > + * :- pred > + * :- func > + * :- inst > + * :- mode > + * :- typeclass > + * :- instance > + * :- pragma > + * :- promise > + * :- initialise > + * :- finalise > + * :- mutable > + * :- module > + * :- interface > + * :- implementation > + * :- import_module > + * :- use_module > + * :- include_module > + * :- end_module > + * followed on the same line by an alphanumeric sequence, starting with a lower > + * case letter or by a single-quoted arbitrary string. > + * Single quotes can escape themselves. Backslash quotes everything. > + * > + * Return the size of the name of the declaration or 0 if no header was found. > + * As quantifiers may precede functions or predicates, we must list them too. > + */ > + > +static const char *Mercury_decl_tags[] = {"type", "solver type", "pred", > + "func", "inst", "mode", "typeclass", "instance", "pragma", "promise", > + "initialise", "finalise", "mutable", "module", "interface", "implementation", > + "import_module", "use_module", "include_module", "end_module", "some", "all"}; > + > +static size_t > +mercury_decl (char *s, size_t pos) > +{ > + if (s == NULL) return 0; > + > + size_t origpos; > + origpos = pos; > + > + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) ++pos; > + > + unsigned char decl_type_length = pos - origpos; > + char buf[decl_type_length + 1]; > + memset (buf, 0, decl_type_length + 1); > + > + /* Mercury declaration tags. Consume them, then check the declaration item > + following :- is legitimate, then go on as in the prolog case. */ > + > + memcpy (buf, &s[origpos], decl_type_length); > + > + bool found_decl_tag = false; > + > + if (is_mercury_quantifier) > + { > + if (strcmp (buf, "pred") != 0 && strcmp (buf, "func") != 0) /* Bad syntax. */ > + return 0; > + is_mercury_quantifier = false; /* Beset to base value. */ > + found_decl_tag = true; > + } > + else > + { > + for (int j = 0; j < sizeof (Mercury_decl_tags) / sizeof (char*); ++j) > + { > + if (strcmp (buf, Mercury_decl_tags[j]) == 0) > + { > + found_decl_tag = true; > + if (strcmp (buf, "type") == 0) > + is_mercury_type = true; > + > + if (strcmp (buf, "some") == 0 > + || strcmp (buf, "all") == 0) > + { > + is_mercury_quantifier = true; > + } > + > + break; /* Found declaration tag of rank j. */ > + } > + else > + /* 'solver type' has a blank in the middle, > + so this is the hard case. */ > + if (strcmp (buf, "solver") == 0) > + { > + ++pos; > + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) > + ++pos; > + > + decl_type_length = pos - origpos; > + char buf2[decl_type_length + 1]; > + memset (buf2, 0, decl_type_length + 1); > + memcpy (buf2, &s[origpos], decl_type_length); > + > + if (strcmp (buf2, "solver type") == 0) > + { > + found_decl_tag = false; > + break; /* Found declaration tag of rank j. */ > + } > + } > + } > + } > + > + /* If with_mercury_definitions == false > + * this is a Mercury syntax error, ignoring... */ > + > + if (with_mercury_definitions) > + { > + if (found_decl_tag) > + pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */ > + else > + /* Prolog-like behavior > + * we have parsed the predicate once, yet inappropriately > + * so restarting again the parsing step. */ > + pos = 0; > + } > + else > + { > + if (found_decl_tag) > + pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */ > + else > + return 0; > + } > + > + /* From now on it is the same as for Prolog except for module dots. */ > + > + if (c_islower (s[pos]) || s[pos] == '_' ) > + { > + /* The name is unquoted. > + Do not confuse module dots with end-of-declaration dots. */ > + > + while (c_isalnum (s[pos]) > + || s[pos] == '_' > + || (s[pos] == '.' /* A module dot. */ > + && s + pos + 1 != NULL > + && (c_isalnum (s[pos + 1]) || s[pos + 1] == '_'))) > + ++pos; > + > + return pos - origpos; > + } > + else if (s[pos] == '\'') > + { > + ++pos; > + for (;;) > + { > + if (s[pos] == '\'') > + { > + ++pos; > + if (s[pos] != '\'') > + break; > + ++pos; /* A double quote. */ > + } > + else if (s[pos] == '\0') /* Multiline quoted atoms are ignored. */ > + return 0; > + else if (s[pos] == '\\') > + { > + if (s[pos+1] == '\0') > + return 0; > + pos += 2; > + } > + else > + ++pos; > + } > + return pos - origpos; > + } > + else if (is_mercury_quantifier && s[pos] == '[') /* :- some [T] pred/func. */ > + { > + for (++pos; s + pos != NULL && s[pos] != ']'; ++pos) {} > + if (s + pos == NULL) return 0; > + ++pos; > + pos = skip_spaces (s + pos) - s; > + return mercury_decl (s, pos) + pos - origpos; > + } > + else > + return 0; > +} > + > +static ptrdiff_t > +mercury_pr (char *s, char *last, ptrdiff_t lastlen) > +{ > + size_t len0 = 0; > + is_mercury_type = false; > + is_mercury_quantifier = false; > + > + if (is_mercury_declaration) > + { > + /* Skip len0 blanks only for declarations. */ > + len0 = skip_spaces (s + 2) - s; > + } > + > + size_t len = mercury_decl (s , len0); > + if (len == 0) return 0; > + len += len0; > + > + if (( (s[len] == '.' /* This is a statement dot, not a module dot. */ > + || (s[len] == '(' && (len += 1)) > + || (s[len] == ':' /* Stopping in case of a rule. */ > + && s[len + 1] == '-' > + && (len += 2))) > + && (lastlen != len || memcmp (s, last, len) != 0) > + ) > + /* Types are often declared on several lines so keeping just > + the first line. */ > + || is_mercury_type) > + { > + make_tag (s, 0, true, s, len, lineno, linecharno); > + return len; > + } > + > + return 0; > +} > + > \f > /* > * Support for Erlang > diff --git a/test/manual/etags/Makefile b/test/manual/etags/Makefile > index c1df703905..eae6918256 100644 > --- a/test/manual/etags/Makefile > +++ b/test/manual/etags/Makefile > @@ -28,10 +28,11 @@ RBSRC= > SCMSRC=$(addprefix ./scm-src/,test.scm) > TEXSRC=$(addprefix ./tex-src/,testenv.tex gzip.texi texinfo.tex nonewline.tex) > YSRC=$(addprefix ./y-src/,parse.y parse.c atest.y cccp.c cccp.y) > +MERCSRC=$(addprefix ./merc-src/,array.m) > SRCS=${ADASRC} ${ASRC} ${CSRC} ${CPSRC} ${ELSRC} ${ERLSRC} ${FSRC}\ > ${FORTHSRC} ${GOSRC} ${HTMLSRC} ${JAVASRC} ${LUASRC} ${MAKESRC}\ > ${OBJCSRC} ${OBJCPPSRC} ${PASSRC} ${PHPSRC} ${PERLSRC} ${PSSRC}\ > - ${PROLSRC} ${PYTSRC} ${RBSRC} ${SCMSRC} ${TEXSRC} ${YSRC} > + ${PROLSRC} ${PYTSRC} ${RBSRC} ${SCMSRC} ${TEXSRC} ${YSRC} ${MERCSRC} > NONSRCS=./f-src/entry.strange ./erl-src/lists.erl ./cp-src/clheir.hpp.gz > > ETAGS_PROG=../../../lib-src/etags > diff --git a/test/manual/etags/merc-src/array.m b/test/manual/etags/merc-src/array.m > new file mode 100644 > index 0000000000..0663c41087 > --- /dev/null > +++ b/test/manual/etags/merc-src/array.m > @@ -0,0 +1,3416 @@ > +%---------------------------------------------------------------------------% > +% vim: ft=mercury ts=4 sw=4 et > +%---------------------------------------------------------------------------% > +% Copyright (C) 1993-1995, 1997-2012 The University of Melbourne. > +% Copyright (C) 2013-2018 The Mercury team. > +% This file is distributed under the terms specified in COPYING.LIB. > +%---------------------------------------------------------------------------% > +% > +% File: array.m. > +% Main authors: fjh, bromage. > +% Stability: medium-low. > +% > +% This module provides dynamically-sized one-dimensional arrays. > +% Array indices start at zero. > +% > +% WARNING! > +% > +% Arrays are currently not unique objects. until this situation is resolved, > +% it is up to the programmer to ensure that arrays are used in ways that > +% preserve correctness. In the absence of mode reordering, one should therefore > +% assume that evaluation will take place in left-to-right order. For example, > +% the following code will probably not work as expected (f is a function, > +% A an array, I an index, and X an appropriate value): > +% > +% Y = f(A ^ elem(I) := X, A ^ elem(I)) > +% > +% The compiler is likely to compile this as > +% > +% V0 = A ^ elem(I) := X, > +% V1 = A ^ elem(I), > +% Y = f(V0, V1) > +% > +% and will be unaware that the first line should be ordered *after* the second. > +% The safest thing to do is write things out by hand in the form > +% > +% A0I = A0 ^ elem(I), > +% A1 = A0 ^ elem(I) := X, > +% Y = f(A1, A0I) > +% > +%---------------------------------------------------------------------------% > +%---------------------------------------------------------------------------% > + > +:- module array. > +:- interface. > + > +:- import_module list. > +:- import_module pretty_printer. > +:- import_module random. > + > +:- type array(T). > + > +:- inst array(I) == ground. > +:- inst array == array(ground). > + > + % XXX the current Mercury compiler doesn't support `ui' modes, > + % so to work-around that problem, we currently don't use > + % unique modes in this module. > + > +% :- inst uniq_array(I) == unique. > +% :- inst uniq_array == uniq_array(unique). > +:- inst uniq_array(I) == array(I). % XXX work-around > +:- inst uniq_array == uniq_array(ground). % XXX work-around > + > +:- mode array_di == di(uniq_array). > +:- mode array_uo == out(uniq_array). > +:- mode array_ui == in(uniq_array). > + > +% :- inst mostly_uniq_array(I) == mostly_unique). > +% :- inst mostly_uniq_array == mostly_uniq_array(mostly_unique). > +:- inst mostly_uniq_array(I) == array(I). % XXX work-around > +:- inst mostly_uniq_array == mostly_uniq_array(ground). % XXX work-around > + > +:- mode array_mdi == mdi(mostly_uniq_array). > +:- mode array_muo == out(mostly_uniq_array). > +:- mode array_mui == in(mostly_uniq_array). > + > + % An `index_out_of_bounds' is the exception thrown > + % on out-of-bounds array accesses. The string describes > + % the predicate or function reporting the error. > +:- type index_out_of_bounds > + ---> index_out_of_bounds(string). > + > +%---------------------------------------------------------------------------% > + > + % make_empty_array(Array) creates an array of size zero > + % starting at lower bound 0. > + % > +:- pred make_empty_array(array(T)::array_uo) is det. > + > +:- func make_empty_array = (array(T)::array_uo) is det. > + > + % init(Size, Init, Array) creates an array with bounds from 0 > + % to Size-1, with each element initialized to Init. Throws an > + % exception if Size < 0. > + % > +:- pred init(int, T, array(T)). > +:- mode init(in, in, array_uo) is det. > + > +:- func init(int, T) = array(T). > +:- mode init(in, in) = array_uo is det. > + > + % array/1 is a function that constructs an array from a list. > + % (It does the same thing as the predicate from_list/2.) > + % The syntax `array([...])' is used to represent arrays > + % for io.read, io.write, term_to_type, and type_to_term. > + % > +:- func array(list(T)) = array(T). > +:- mode array(in) = array_uo is det. > + > + % generate(Size, Generate) = Array: > + % Create an array with bounds from 0 to Size - 1 using the function > + % Generate to set the initial value of each element of the array. > + % The initial value of the element at index K will be the result of > + % calling the function Generate(K). Throws an exception if Size < 0. > + % > +:- func generate(int::in, (func(int) = T)::in) = (array(T)::array_uo) > + is det. > + > + % generate_foldl(Size, Generate, Array, !Acc): > + % As above, but using a predicate with an accumulator threaded through it > + % to generate the initial value of each element. > + % > +:- pred generate_foldl(int, pred(int, T, A, A), array(T), A, A). > +:- mode generate_foldl(in, in(pred(in, out, in, out) is det), > + array_uo, in, out) is det. > +:- mode generate_foldl(in, in(pred(in, out, mdi, muo) is det), > + array_uo, mdi, muo) is det. > +:- mode generate_foldl(in, in(pred(in, out, di, uo) is det), > + array_uo, di, uo) is det. > +:- mode generate_foldl(in, in(pred(in, out, in, out) is semidet), > + array_uo, in, out) is semidet. > +:- mode generate_foldl(in, in(pred(in, out, mdi, muo) is semidet), > + array_uo, mdi, muo) is semidet. > +:- mode generate_foldl(in, in(pred(in, out, di, uo) is semidet), > + array_uo, di, uo) is semidet. > + > +%---------------------------------------------------------------------------% > + > + % min returns the lower bound of the array. > + % Note: in this implementation, the lower bound is always zero. > + % > +:- pred min(array(_T), int). > +%:- mode min(array_ui, out) is det. > +:- mode min(in, out) is det. > + > +:- func min(array(_T)) = int. > +%:- mode min(array_ui) = out is det. > +:- mode min(in) = out is det. > + > + % det_least_index returns the lower bound of the array. > + % Throws an exception if the array is empty. > + % > +:- func det_least_index(array(T)) = int. > +%:- mode det_least_index(array_ui) = out is det. > +:- mode det_least_index(in) = out is det. > + > + % semidet_least_index returns the lower bound of the array, > + % or fails if the array is empty. > + % > +:- func semidet_least_index(array(T)) = int. > +%:- mode semidet_least_index(array_ui) = out is semidet. > +:- mode semidet_least_index(in) = out is semidet. > + > + % max returns the upper bound of the array. > + % Returns lower bound - 1 for an empty array > + % (always -1 in this implementation). > + % > +:- pred max(array(_T), int). > +%:- mode max(array_ui, out) is det. > +:- mode max(in, out) is det. > + > +:- func max(array(_T)) = int. > +%:- mode max(array_ui) = out is det. > +:- mode max(in) = out is det. > + > + % det_greatest_index returns the upper bound of the array. > + % Throws an exception if the array is empty. > + % > +:- func det_greatest_index(array(T)) = int. > +%:- mode det_greatest_index(array_ui) = out is det. > +:- mode det_greatest_index(in) = out is det. > + > + % semidet_greatest_index returns the upper bound of the array, > + % or fails if the array is empty. > + % > +:- func semidet_greatest_index(array(T)) = int. > +%:- mode semidet_greatest_index(array_ui) = out is semidet. > +:- mode semidet_greatest_index(in) = out is semidet. > + > + % size returns the length of the array, > + % i.e. upper bound - lower bound + 1. > + % > +:- pred size(array(_T), int). > +%:- mode size(array_ui, out) is det. > +:- mode size(in, out) is det. > + > +:- func size(array(_T)) = int. > +%:- mode size(array_ui) = out is det. > +:- mode size(in) = out is det. > + > + % bounds(Array, Min, Max) returns the lower and upper bounds of an array. > + % The upper bound will be lower bound - 1 for an empty array. > + % Note: in this implementation, the lower bound is always zero. > + % > +:- pred bounds(array(_T), int, int). > +%:- mode bounds(array_ui, out, out) is det. > +:- mode bounds(in, out, out) is det. > + > + % in_bounds checks whether an index is in the bounds of an array. > + % > +:- pred in_bounds(array(_T), int). > +%:- mode in_bounds(array_ui, in) is semidet. > +:- mode in_bounds(in, in) is semidet. > + > + % is_empty(Array): > + % True iff Array is an array of size zero. > + % > +:- pred is_empty(array(_T)). > +%:- mode is_empty(array_ui) is semidet. > +:- mode is_empty(in) is semidet. > + > +%---------------------------------------------------------------------------% > + > + % lookup returns the N'th element of an array. > + % Throws an exception if the index is out of bounds. > + % > +:- pred lookup(array(T), int, T). > +%:- mode lookup(array_ui, in, out) is det. > +:- mode lookup(in, in, out) is det. > + > +:- func lookup(array(T), int) = T. > +%:- mode lookup(array_ui, in) = out is det. > +:- mode lookup(in, in) = out is det. > + > + % semidet_lookup returns the N'th element of an array. > + % It fails if the index is out of bounds. > + % > +:- pred semidet_lookup(array(T), int, T). > +%:- mode semidet_lookup(array_ui, in, out) is semidet. > +:- mode semidet_lookup(in, in, out) is semidet. > + > + % unsafe_lookup returns the N'th element of an array. > + % It is an error if the index is out of bounds. > + % > +:- pred unsafe_lookup(array(T), int, T). > +%:- mode unsafe_lookup(array_ui, in, out) is det. > +:- mode unsafe_lookup(in, in, out) is det. > + > + % set sets the N'th element of an array, and returns the > + % resulting array (good opportunity for destructive update ;-). > + % Throws an exception if the index is out of bounds. > + % > +:- pred set(int, T, array(T), array(T)). > +:- mode set(in, in, array_di, array_uo) is det. > + > +:- func set(array(T), int, T) = array(T). > +:- mode set(array_di, in, in) = array_uo is det. > + > + % semidet_set sets the nth element of an array, and returns > + % the resulting array. It fails if the index is out of bounds. > + % > +:- pred semidet_set(int, T, array(T), array(T)). > +:- mode semidet_set(in, in, array_di, array_uo) is semidet. > + > + % unsafe_set sets the nth element of an array, and returns the > + % resulting array. It is an error if the index is out of bounds. > + % > +:- pred unsafe_set(int, T, array(T), array(T)). > +:- mode unsafe_set(in, in, array_di, array_uo) is det. > + > + % slow_set sets the nth element of an array, and returns the > + % resulting array. The initial array is not required to be unique, > + % so the implementation may not be able to use destructive update. > + % It is an error if the index is out of bounds. > + % > +:- pred slow_set(int, T, array(T), array(T)). > +%:- mode slow_set(in, in, array_ui, array_uo) is det. > +:- mode slow_set(in, in, in, array_uo) is det. > + > +:- func slow_set(array(T), int, T) = array(T). > +%:- mode slow_set(array_ui, in, in) = array_uo is det. > +:- mode slow_set(in, in, in) = array_uo is det. > + > + % semidet_slow_set sets the nth element of an array, and returns > + % the resulting array. The initial array is not required to be unique, > + % so the implementation may not be able to use destructive update. > + % It fails if the index is out of bounds. > + % > +:- pred semidet_slow_set(int, T, array(T), array(T)). > +%:- mode semidet_slow_set(in, in, array_ui, array_uo) is semidet. > +:- mode semidet_slow_set(in, in, in, array_uo) is semidet. > + > + % Field selection for arrays. > + % Array ^ elem(Index) = lookup(Array, Index). > + % > +:- func elem(int, array(T)) = T. > +%:- mode elem(in, array_ui) = out is det. > +:- mode elem(in, in) = out is det. > + > + % As above, but omit the bounds check. > + % > +:- func unsafe_elem(int, array(T)) = T. > +%:- mode unsafe_elem(in, array_ui) = out is det. > +:- mode unsafe_elem(in, in) = out is det. > + > + % Field update for arrays. > + % (Array ^ elem(Index) := Value) = set(Array, Index, Value). > + % > +:- func 'elem :='(int, array(T), T) = array(T). > +:- mode 'elem :='(in, array_di, in) = array_uo is det. > + > + % As above, but omit the bounds check. > + % > +:- func 'unsafe_elem :='(int, array(T), T) = array(T). > +:- mode 'unsafe_elem :='(in, array_di, in) = array_uo is det. > + > + % swap(I, J, !Array): > + % Swap the item in the I'th position with the item in the J'th position. > + % Throws an exception if either of I or J is out-of-bounds. > + % > +:- pred swap(int, int, array(T), array(T)). > +:- mode swap(in, in, array_di, array_uo) is det. > + > + % As above, but omit the bounds checks. > + % > +:- pred unsafe_swap(int, int, array(T), array(T)). > +:- mode unsafe_swap(in, in, array_di, array_uo) is det. > + > + % Returns every element of the array, one by one. > + % > +:- pred member(array(T)::in, T::out) is nondet. > + > +%---------------------------------------------------------------------------% > + > + % copy(Array0, Array): > + % Makes a new unique copy of an array. > + % > +:- pred copy(array(T), array(T)). > +%:- mode copy(array_ui, array_uo) is det. > +:- mode copy(in, array_uo) is det. > + > +:- func copy(array(T)) = array(T). > +%:- mode copy(array_ui) = array_uo is det. > +:- mode copy(in) = array_uo is det. > + > + % resize(Size, Init, Array0, Array): > + % The array is expanded or shrunk to make it fit the new size `Size'. > + % Any new entries are filled with `Init'. Throws an exception if > + % `Size' < 0. > + % > +:- pred resize(int, T, array(T), array(T)). > +:- mode resize(in, in, array_di, array_uo) is det. > + > + % resize(Array0, Size, Init) = Array: > + % The array is expanded or shrunk to make it fit the new size `Size'. > + % Any new entries are filled with `Init'. Throws an exception if > + % `Size' < 0. > + % > +:- func resize(array(T), int, T) = array(T). > +:- mode resize(array_di, in, in) = array_uo is det. > + > + % shrink(Size, Array0, Array): > + % The array is shrunk to make it fit the new size `Size'. > + % Throws an exception if `Size' is larger than the size of `Array0' or > + % if `Size' < 0. > + % > +:- pred shrink(int, array(T), array(T)). > +:- mode shrink(in, array_di, array_uo) is det. > + > + % shrink(Array0, Size) = Array: > + % The array is shrunk to make it fit the new size `Size'. > + % Throws an exception if `Size' is larger than the size of `Array0' or > + % if `Size' < 0. > + % > +:- func shrink(array(T), int) = array(T). > +:- mode shrink(array_di, in) = array_uo is det. > + > + % fill(Item, Array0, Array): > + % Sets every element of the array to `Elem'. > + % > +:- pred fill(T::in, array(T)::array_di, array(T)::array_uo) is det. > + > + % fill_range(Item, Lo, Hi, !Array): > + % Sets every element of the array with index in the range Lo..Hi > + % (inclusive) to Item. Throws a software_error/1 exception if Lo > Hi. > + % Throws an index_out_of_bounds/0 exception if Lo or Hi is out of bounds. > + % > +:- pred fill_range(T::in, int::in, int::in, > + array(T)::array_di, array(T)::array_uo) is det. > + > + % from_list takes a list, and returns an array containing those > + % elements in the same order that they occurred in the list. > + % > +:- func from_list(list(T)::in) = (array(T)::array_uo) is det. > +:- pred from_list(list(T)::in, array(T)::array_uo) is det. > + > + % from_reverse_list takes a list, and returns an array containing > + % those elements in the reverse order that they occurred in the list. > + % > +:- func from_reverse_list(list(T)::in) = (array(T)::array_uo) is det. > + > + % to_list takes an array and returns a list containing the elements > + % of the array in the same order that they occurred in the array. > + % > +:- pred to_list(array(T), list(T)). > +%:- mode to_list(array_ui, out) is det. > +:- mode to_list(in, out) is det. > + > +:- func to_list(array(T)) = list(T). > +%:- mode to_list(array_ui) = out is det. > +:- mode to_list(in) = out is det. > + > + % fetch_items(Array, Lo, Hi, List): > + % Returns a list containing the items in the array with index in the range > + % Lo..Hi (both inclusive) in the same order that they occurred in the > + % array. Returns an empty list if Hi < Lo. Throws an index_out_of_bounds/0 > + % exception if either Lo or Hi is out of bounds, *and* Hi >= Lo. > + % > + % If Hi < Lo, we do not generate an exception even if either or both > + % are out of bounds, for two reasons. First, there is no need; if Hi < Lo, > + % we can return the empty list without accessing any element of the array. > + % Second, without this rule, some programming techniques for accessing > + % consecutive contiguous regions of an array would require explicit > + % bound checks in the *caller* of fetch_items, which would duplicate > + % the checks inside fetch_items itself. > + % > +:- pred fetch_items(array(T), int, int, list(T)). > +:- mode fetch_items(in, in, in, out) is det. > + > +:- func fetch_items(array(T), int, int) = list(T). > +%:- mode fetch_items(array_ui, in, in) = out is det. > +:- mode fetch_items(in, in, in) = out is det. > + > + % binary_search(A, X, I) does a binary search for the element X > + % in the array A. If there is an element with that value in the array, > + % it returns its index I; otherwise, it fails. > + % > + % The array A must be sorted into ascending order with respect to the > + % the builtin Mercury order on terms for binary_search/3, and with respect > + % to supplied comparison predicate for binary_search/4. > + % > + % The array may contain duplicates. If it does, and a search looks for > + % a duplicated value, the search will return the index of one of the > + % copies, but it is not specified *which* copy's index it will return. > + % > +:- pred binary_search(array(T)::array_ui, > + T::in, int::out) is semidet. > +:- pred binary_search(comparison_func(T)::in, array(T)::array_ui, > + T::in, int::out) is semidet. > + > + % approx_binary_search(A, X, I) does a binary search for the element X > + % in the array A. If there is an element with that value in the array, > + % it returns its index I. If there is no element with that value in the > + % array, it returns an index whose slot contains the highest value in the > + % array that is less than X, as measured by the builtin Mercury order > + % on terms for approx_binary_search/3, and as measured by the supplied > + % ordering for approx_binary_search/4. It will fail only if there is > + % no value smaller than X in the array. > + % > + % The array A must be sorted into ascending order with respect to the > + % the builtin Mercury order on terms for approx_binary_search/3, and > + % with respect to supplied comparison predicate for approx_binary_search/4. > + % > + % The array may contain duplicates. If it does, and if either the > + % searched-for value or (if that does not exist) the highest value > + % smaller than the searched-for value is duplicated, the search will return > + % the index of one of the copies, but it is not specified *which* copy's > + % index it will return. > + % > +:- pred approx_binary_search(array(T)::array_ui, > + T::in, int::out) is semidet. > +:- pred approx_binary_search(comparison_func(T)::in, array(T)::array_ui, > + T::in, int::out) is semidet. > + > + % map(Closure, OldArray, NewArray) applies `Closure' to > + % each of the elements of `OldArray' to create `NewArray'. > + % > +:- pred map(pred(T1, T2), array(T1), array(T2)). > +%:- mode map(pred(in, out) is det, array_ui, array_uo) is det. > +:- mode map(pred(in, out) is det, in, array_uo) is det. > + > +:- func map(func(T1) = T2, array(T1)) = array(T2). > +%:- mode map(func(in) = out is det, array_ui) = array_uo is det. > +:- mode map(func(in) = out is det, in) = array_uo is det. > + > +:- func array_compare(array(T), array(T)) = comparison_result. > +:- mode array_compare(in, in) = uo is det. > + > + % sort(Array) returns a version of Array sorted into ascending > + % order. > + % > + % This sort is not stable. That is, elements that compare/3 decides are > + % equal will appear together in the sorted array, but not necessarily > + % in the same order in which they occurred in the input array. This is > + % primarily only an issue with types with user-defined equivalence for > + % which `equivalent' objects are otherwise distinguishable. > + % > +:- func sort(array(T)) = array(T). > +:- mode sort(array_di) = array_uo is det. > + > + % array.sort was previously buggy. This symbol provides a way to ensure > + % that you are using the fixed version. > + % > +:- pred array.sort_fix_2014 is det. > + > + % foldl(Fn, Array, X) is equivalent to > + % list.foldl(Fn, to_list(Array), X) > + % but more efficient. > + % > +:- func foldl(func(T1, T2) = T2, array(T1), T2) = T2. > +%:- mode foldl(func(in, in) = out is det, array_ui, in) = out is det. > +:- mode foldl(func(in, in) = out is det, in, in) = out is det. > +%:- mode foldl(func(in, di) = uo is det, array_ui, di) = uo is det. > +:- mode foldl(func(in, di) = uo is det, in, di) = uo is det. > + > + % foldl(Pr, Array, !X) is equivalent to > + % list.foldl(Pr, to_list(Array), !X) > + % but more efficient. > + % > +:- pred foldl(pred(T1, T2, T2), array(T1), T2, T2). > +:- mode foldl(pred(in, in, out) is det, in, in, out) is det. > +:- mode foldl(pred(in, mdi, muo) is det, in, mdi, muo) is det. > +:- mode foldl(pred(in, di, uo) is det, in, di, uo) is det. > +:- mode foldl(pred(in, in, out) is semidet, in, in, out) is semidet. > +:- mode foldl(pred(in, mdi, muo) is semidet, in, mdi, muo) is semidet. > +:- mode foldl(pred(in, di, uo) is semidet, in, di, uo) is semidet. > + > + % foldl2(Pr, Array, !X, !Y) is equivalent to > + % list.foldl2(Pr, to_list(Array), !X, !Y) > + % but more efficient. > + % > +:- pred foldl2(pred(T1, T2, T2, T3, T3), array(T1), T2, T2, T3, T3). > +:- mode foldl2(pred(in, in, out, in, out) is det, in, in, out, in, out) > + is det. > +:- mode foldl2(pred(in, in, out, mdi, muo) is det, in, in, out, mdi, muo) > + is det. > +:- mode foldl2(pred(in, in, out, di, uo) is det, in, in, out, di, uo) > + is det. > +:- mode foldl2(pred(in, in, out, in, out) is semidet, in, > + in, out, in, out) is semidet. > +:- mode foldl2(pred(in, in, out, mdi, muo) is semidet, in, > + in, out, mdi, muo) is semidet. > +:- mode foldl2(pred(in, in, out, di, uo) is semidet, in, > + in, out, di, uo) is semidet. > + > + % As above, but with three accumulators. > + % > +:- pred foldl3(pred(T1, T2, T2, T3, T3, T4, T4), array(T1), > + T2, T2, T3, T3, T4, T4). > +:- mode foldl3(pred(in, in, out, in, out, in, out) is det, > + in, in, out, in, out, in, out) is det. > +:- mode foldl3(pred(in, in, out, in, out, mdi, muo) is det, > + in, in, out, in, out, mdi, muo) is det. > +:- mode foldl3(pred(in, in, out, in, out, di, uo) is det, > + in, in, out, in, out, di, uo) is det. > +:- mode foldl3(pred(in, in, out, in, out, in, out) is semidet, > + in, in, out, in, out, in, out) is semidet. > +:- mode foldl3(pred(in, in, out, in, out, mdi, muo) is semidet, > + in, in, out, in, out, mdi, muo) is semidet. > +:- mode foldl3(pred(in, in, out, in, out, di, uo) is semidet, > + in, in, out, in, out, di, uo) is semidet. > + > + % As above, but with four accumulators. > + % > +:- pred foldl4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), array(T1), > + T2, T2, T3, T3, T4, T4, T5, T5). > +:- mode foldl4(pred(in, in, out, in, out, in, out, in, out) is det, > + in, in, out, in, out, in, out, in, out) is det. > +:- mode foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is det, > + in, in, out, in, out, in, out, mdi, muo) is det. > +:- mode foldl4(pred(in, in, out, in, out, in, out, di, uo) is det, > + in, in, out, in, out, in, out, di, uo) is det. > +:- mode foldl4(pred(in, in, out, in, out, in, out, in, out) is semidet, > + in, in, out, in, out, in, out, in, out) is semidet. > +:- mode foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode foldl4(pred(in, in, out, in, out, in, out, di, uo) is semidet, > + in, in, out, in, out, in, out, di, uo) is semidet. > + > + % As above, but with five accumulators. > + % > +:- pred foldl5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), > + array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). > +:- mode foldl5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is det, > + in, in, out, in, out, in, out, in, out, in, out) is det. > +:- mode foldl5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, > + in, in, out, in, out, in, out, in, out, mdi, muo) is det. > +:- mode foldl5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, > + in, in, out, in, out, in, out, in, out, di, uo) is det. > +:- mode foldl5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, > + in, in, out, in, out, in, out, in, out, in, out) is semidet. > +:- mode foldl5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode foldl5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, > + in, in, out, in, out, in, out, in, out, di, uo) is semidet. > + > +%---------------------% > + > + % foldr(Fn, Array, X) is equivalent to > + % list.foldr(Fn, to_list(Array), X) > + % but more efficient. > + % > +:- func foldr(func(T1, T2) = T2, array(T1), T2) = T2. > +%:- mode foldr(func(in, in) = out is det, array_ui, in) = out is det. > +:- mode foldr(func(in, in) = out is det, in, in) = out is det. > +%:- mode foldr(func(in, di) = uo is det, array_ui, di) = uo is det. > +:- mode foldr(func(in, di) = uo is det, in, di) = uo is det. > + > + % foldr(P, Array, !Acc) is equivalent to > + % list.foldr(P, to_list(Array), !Acc) > + % but more efficient. > + % > +:- pred foldr(pred(T1, T2, T2), array(T1), T2, T2). > +:- mode foldr(pred(in, in, out) is det, in, in, out) is det. > +:- mode foldr(pred(in, mdi, muo) is det, in, mdi, muo) is det. > +:- mode foldr(pred(in, di, uo) is det, in, di, uo) is det. > +:- mode foldr(pred(in, in, out) is semidet, in, in, out) is semidet. > +:- mode foldr(pred(in, mdi, muo) is semidet, in, mdi, muo) is semidet. > +:- mode foldr(pred(in, di, uo) is semidet, in, di, uo) is semidet. > + > + % As above, but with two accumulators. > + % > +:- pred foldr2(pred(T1, T2, T2, T3, T3), array(T1), T2, T2, T3, T3). > +:- mode foldr2(pred(in, in, out, in, out) is det, in, in, out, in, out) > + is det. > +:- mode foldr2(pred(in, in, out, mdi, muo) is det, in, in, out, mdi, muo) > + is det. > +:- mode foldr2(pred(in, in, out, di, uo) is det, in, in, out, di, uo) > + is det. > +:- mode foldr2(pred(in, in, out, in, out) is semidet, in, > + in, out, in, out) is semidet. > +:- mode foldr2(pred(in, in, out, mdi, muo) is semidet, in, > + in, out, mdi, muo) is semidet. > +:- mode foldr2(pred(in, in, out, di, uo) is semidet, in, > + in, out, di, uo) is semidet. > + > + % As above, but with three accumulators. > + % > +:- pred foldr3(pred(T1, T2, T2, T3, T3, T4, T4), array(T1), > + T2, T2, T3, T3, T4, T4). > +:- mode foldr3(pred(in, in, out, in, out, in, out) is det, in, > + in, out, in, out, in, out) is det. > +:- mode foldr3(pred(in, in, out, in, out, mdi, muo) is det, in, > + in, out, in, out, mdi, muo) is det. > +:- mode foldr3(pred(in, in, out, in, out, di, uo) is det, in, > + in, out, in, out, di, uo) is det. > +:- mode foldr3(pred(in, in, out, in, out, in, out) is semidet, in, > + in, out, in, out, in, out) is semidet. > +:- mode foldr3(pred(in, in, out, in, out, mdi, muo) is semidet, in, > + in, out, in, out, mdi, muo) is semidet. > +:- mode foldr3(pred(in, in, out, in, out, di, uo) is semidet, in, > + in, out, in, out, di, uo) is semidet. > + > + % As above, but with four accumulators. > + % > +:- pred foldr4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), array(T1), > + T2, T2, T3, T3, T4, T4, T5, T5). > +:- mode foldr4(pred(in, in, out, in, out, in, out, in, out) is det, > + in, in, out, in, out, in, out, in, out) is det. > +:- mode foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is det, > + in, in, out, in, out, in, out, mdi, muo) is det. > +:- mode foldr4(pred(in, in, out, in, out, in, out, di, uo) is det, > + in, in, out, in, out, in, out, di, uo) is det. > +:- mode foldr4(pred(in, in, out, in, out, in, out, in, out) is semidet, > + in, in, out, in, out, in, out, in, out) is semidet. > +:- mode foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode foldr4(pred(in, in, out, in, out, in, out, di, uo) is semidet, > + in, in, out, in, out, in, out, di, uo) is semidet. > + > + % As above, but with five accumulators. > + % > +:- pred foldr5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), > + array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). > +:- mode foldr5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is det, > + in, in, out, in, out, in, out, in, out, in, out) is det. > +:- mode foldr5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, > + in, in, out, in, out, in, out, in, out, mdi, muo) is det. > +:- mode foldr5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, > + in, in, out, in, out, in, out, in, out, di, uo) is det. > +:- mode foldr5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, > + in, in, out, in, out, in, out, in, out, in, out) is semidet. > +:- mode foldr5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode foldr5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, > + in, in, out, in, out, in, out, in, out, di, uo) is semidet. > + > +%---------------------% > + > + % foldl_corresponding(P, A, B, !Acc): > + % > + % Does the same job as foldl, but works on two arrays in parallel. > + % Throws an exception if the array arguments differ in size. > + % > +:- pred foldl_corresponding(pred(T1, T2, T3, T3), array(T1), array(T2), > + T3, T3). > +:- mode foldl_corresponding(in(pred(in, in, in, out) is det), in, in, > + in, out) is det. > +:- mode foldl_corresponding(in(pred(in, in, mdi, muo) is det), in, in, > + mdi, muo) is det. > +:- mode foldl_corresponding(in(pred(in, in, di, uo) is det), in, in, > + di, uo) is det. > +:- mode foldl_corresponding(in(pred(in, in, in, out) is semidet), in, in, > + in, out) is semidet. > +:- mode foldl_corresponding(in(pred(in, in, mdi, muo) is semidet), in, in, > + mdi, muo) is semidet. > +:- mode foldl_corresponding(in(pred(in, in, di, uo) is semidet), in, in, > + di, uo) is semidet. > + > + % As above, but with two accumulators. > + % > +:- pred foldl2_corresponding(pred(T1, T2, T3, T3, T4, T4), > + array(T1), array(T2), T3, T3, T4, T4). > +:- mode foldl2_corresponding(in(pred(in, in, in, out, in, out) is det), > + in, in, in, out, in, out) is det. > +:- mode foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is det), > + in, in, in, out, mdi, muo) is det. > +:- mode foldl2_corresponding(in(pred(in, in, in, out, di, uo) is det), > + in, in, in, out, di, uo) is det. > +:- mode foldl2_corresponding(in(pred(in, in, in, out, in, out) is semidet), > + in, in, in, out, in, out) is semidet. > +:- mode foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is semidet), > + in, in, in, out, mdi, muo) is semidet. > +:- mode foldl2_corresponding(in(pred(in, in, in, out, di, uo) is semidet), > + in, in, in, out, di, uo) is semidet. > + > +%---------------------% > + > + % map_foldl(P, A, B, !Acc): > + % Invoke P(Aelt, Belt, !Acc) on each element of the A array, > + % and construct array B from the resulting values of Belt. > + % > +:- pred map_foldl(pred(T1, T2, T3, T3), array(T1), array(T2), T3, T3). > +:- mode map_foldl(in(pred(in, out, in, out) is det), > + in, array_uo, in, out) is det. > +:- mode map_foldl(in(pred(in, out, mdi, muo) is det), > + in, array_uo, mdi, muo) is det. > +:- mode map_foldl(in(pred(in, out, di, uo) is det), > + in, array_uo, di, uo) is det. > +:- mode map_foldl(in(pred(in, out, in, out) is semidet), > + in, array_uo, in, out) is semidet. > + > +%---------------------% > + > + % map_corresponding_foldl(P, A, B, C, !Acc): > + % > + % Given two arrays A and B, invoke P(Aelt, Belt, Celt, !Acc) on > + % each corresponding pair of elements Aelt and Belt. Build up the array C > + % from the result Celt values. Return C and the final value of the > + % accumulator. > + % > + % Throws an exception if A and B differ in size. > + % > +:- pred map_corresponding_foldl(pred(T1, T2, T3, T4, T4), > + array(T1), array(T2), array(T3), T4, T4). > +:- mode map_corresponding_foldl( > + in(pred(in, in, out, in, out) is det), > + in, in, array_uo, in, out) is det. > +:- mode map_corresponding_foldl( > + in(pred(in, in, out, mdi, muo) is det), > + in, in, array_uo, mdi, muo) is det. > +:- mode map_corresponding_foldl( > + in(pred(in, in, out, di, uo) is det), > + in, in, array_uo, di, uo) is det. > +:- mode map_corresponding_foldl( > + in(pred(in, in, out, in, out) is semidet), > + in, in, array_uo, in, out) is semidet. > +:- mode map_corresponding_foldl( > + in(pred(in, in, out, mdi, muo) is semidet), > + in, in, array_uo, mdi, muo) is semidet. > +:- mode map_corresponding_foldl( > + in(pred(in, in, out, di, uo) is semidet), > + in, in, array_uo, di, uo) is semidet. > + > +%---------------------% > + > + % all_true(Pred, Array): > + % True iff Pred is true for every element of Array. > + % > +:- pred all_true(pred(T), array(T)). > +%:- mode all_true(in(pred(in) is semidet), array_ui) is semidet. > +:- mode all_true(in(pred(in) is semidet), in) is semidet. > + > + % all_false(Pred, Array): > + % True iff Pred is false for every element of Array. > + % > +:- pred all_false(pred(T), array(T)). > +%:- mode all_false(in(pred(in) is semidet), array_ui) is semidet. > +:- mode all_false(in(pred(in) is semidet), in) is semidet. > + > + % append(A, B) = C: > + % > + % Make C a concatenation of the arrays A and B. > + % > +:- func append(array(T)::in, array(T)::in) = (array(T)::array_uo) is det. > + > + % random_permutation(A0, A, RS0, RS) permutes the elements in > + % A0 given random seed RS0 and returns the permuted array in A > + % and the next random seed in RS. > + % > +:- pred random_permutation(array(T)::array_di, array(T)::array_uo, > + random.supply::mdi, random.supply::muo) is det. > + > + % Convert an array to a pretty_printer.doc for formatting. > + % > +:- func array_to_doc(array(T)) = pretty_printer.doc. > +:- mode array_to_doc(array_ui) = out is det. > + > +%---------------------------------------------------------------------------% > +%---------------------------------------------------------------------------% > + > +:- implementation. > + > +% Everything beyond here is not intended as part of the public interface, > +% and will not appear in the Mercury Library Reference Manual. > + > +:- interface. > + > + % dynamic_cast/2 won't work for arbitrary arrays since array/1 is > + % not a ground type (that is, dynamic_cast/2 will work when the > + % target type is e.g. array(int), but not when it is array(T)). > + % > +:- some [T2] pred dynamic_cast_to_array(T1::in, array(T2)::out) is semidet. > + > +:- implementation. > + > +:- import_module exception. > +:- import_module int. > +:- import_module require. > +:- import_module string. > +:- import_module type_desc. > + > +% > +% Define the array type appropriately for the different targets. > +% Note that the definitions here should match what is output by > +% mlds_to_c.m, mlds_to_csharp.m, or mlds_to_java.m for mlds.mercury_array_type. > +% > + > + % MR_ArrayPtr is defined in runtime/mercury_types.h. > +:- pragma foreign_type("C", array(T), "MR_ArrayPtr") > + where equality is array.array_equal, > + comparison is array.array_compare. > + > +:- pragma foreign_type("C#", array(T), "System.Array") > + where equality is array.array_equal, > + comparison is array.array_compare. > + > + % We can't use `java.lang.Object []', since we want a generic type > + % that is capable of holding any kind of array, including e.g. `int []'. > + % Java doesn't have any equivalent of .NET's System.Array class, > + % so we just use the universal base `java.lang.Object'. > +:- pragma foreign_type("Java", array(T), "/* Array */ java.lang.Object") > + where equality is array.array_equal, > + comparison is array.array_compare. > + > + % unify/2 for arrays > + % > +:- pred array_equal(array(T)::in, array(T)::in) is semidet. > +:- pragma terminates(array_equal/2). > + > +array_equal(Array1, Array2) :- > + ( if > + array.size(Array1, Size), > + array.size(Array2, Size) > + then > + equal_elements(0, Size, Array1, Array2) > + else > + fail > + ). > + > +:- pred equal_elements(int, int, array(T), array(T)). > +:- mode equal_elements(in, in, in, in) is semidet. > + > +equal_elements(N, Size, Array1, Array2) :- > + ( if N = Size then > + true > + else > + array.unsafe_lookup(Array1, N, Elem), > + array.unsafe_lookup(Array2, N, Elem), > + N1 = N + 1, > + equal_elements(N1, Size, Array1, Array2) > + ). > + > +array_compare(A1, A2) = C :- > + array_compare(C, A1, A2). > + > + % compare/3 for arrays > + % > +:- pred array_compare(comparison_result::uo, array(T)::in, array(T)::in) > + is det. > +:- pragma terminates(array_compare/3). > + > +array_compare(Result, Array1, Array2) :- > + array.size(Array1, Size1), > + array.size(Array2, Size2), > + compare(SizeResult, Size1, Size2), > + ( > + SizeResult = (=), > + compare_elements(0, Size1, Array1, Array2, Result) > + ; > + ( SizeResult = (<) > + ; SizeResult = (>) > + ), > + Result = SizeResult > + ). > + > +:- pred compare_elements(int::in, int::in, array(T)::in, array(T)::in, > + comparison_result::uo) is det. > + > +compare_elements(N, Size, Array1, Array2, Result) :- > + ( if N = Size then > + Result = (=) > + else > + array.unsafe_lookup(Array1, N, Elem1), > + array.unsafe_lookup(Array2, N, Elem2), > + compare(ElemResult, Elem1, Elem2), > + ( > + ElemResult = (=), > + N1 = N + 1, > + compare_elements(N1, Size, Array1, Array2, Result) > + ; > + ( ElemResult = (<) > + ; ElemResult = (>) > + ), > + Result = ElemResult > + ) > + ). > + > +%---------------------------------------------------------------------------% > + > +:- pred bounds_checks is semidet. > +:- pragma inline(bounds_checks/0). > + > +:- pragma foreign_proc("C", > + bounds_checks, > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, no_sharing], > +" > +#ifdef ML_OMIT_ARRAY_BOUNDS_CHECKS > + SUCCESS_INDICATOR = MR_FALSE; > +#else > + SUCCESS_INDICATOR = MR_TRUE; > +#endif > +"). > + > +:- pragma foreign_proc("C#", > + bounds_checks, > + [will_not_call_mercury, promise_pure, thread_safe], > +" > +#if ML_OMIT_ARRAY_BOUNDS_CHECKS > + SUCCESS_INDICATOR = false; > +#else > + SUCCESS_INDICATOR = true; > +#endif > +"). > + > +:- pragma foreign_proc("Java", > + bounds_checks, > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + // never do bounds checking for Java (throw exceptions instead) > + SUCCESS_INDICATOR = false; > +"). > + > +%---------------------------------------------------------------------------% > + > +:- pragma foreign_decl("C", " > +#include ""mercury_heap.h"" // for MR_maybe_record_allocation() > +#include ""mercury_library_types.h"" // for MR_ArrayPtr > + > +// We do not yet record term sizes for arrays in term size profiling > +// grades. Doing so would require > +// > +// - modifying ML_alloc_array to allocate an extra word for the size; > +// - modifying all the predicates that call ML_alloc_array to compute the > +// size of the array (the sum of the sizes of the elements and the size of > +// the array itself); > +// - modifying all the predicates that update array elements to compute the > +// difference between the sizes of the terms being added to and deleted from > +// the array, and updating the array size accordingly. > + > +#define ML_alloc_array(newarray, arraysize, alloc_id) \ > + do { \ > + MR_Word newarray_word; \ > + MR_offset_incr_hp_msg(newarray_word, 0, (arraysize), \ > + alloc_id, ""array.array/1""); \ > + (newarray) = (MR_ArrayPtr) newarray_word; \ > + } while (0) > +"). > + > +:- pragma foreign_decl("C", " > +void ML_init_array(MR_ArrayPtr, MR_Integer size, MR_Word item); > +"). > + > +:- pragma foreign_code("C", " > +// The caller is responsible for allocating the memory for the array. > +// This routine does the job of initializing the already-allocated memory. > +void > +ML_init_array(MR_ArrayPtr array, MR_Integer size, MR_Word item) > +{ > + MR_Integer i; > + > + array->size = size; > + for (i = 0; i < size; i++) { > + array->elements[i] = item; > + } > +} > +"). > + > +:- pragma foreign_code("C#", " > + > +public static System.Array > +ML_new_array(int Size, object Item) > +{ > + System.Array arr; > + if (Size == 0) { > + return null; > + } > + if ( > + Item is int || Item is uint || Item is sbyte || Item is byte || > + Item is short || Item is ushort || Item is long || Item is ulong || > + Item is double || Item is char || Item is bool > + ) { > + arr = System.Array.CreateInstance(Item.GetType(), Size); > + } else { > + arr = new object[Size]; > + } > + for (int i = 0; i < Size; i++) { > + arr.SetValue(Item, i); > + } > + return arr; > +} > + > +public static System.Array > +ML_unsafe_new_array(int Size, object Item, int IndexToSet) > +{ > + System.Array arr; > + > + if ( > + Item is int || Item is uint || Item is sbyte || Item is byte || > + Item is short || Item is ushort || Item is long || Item is ulong || > + Item is double || Item is char || Item is bool > + ) { > + arr = System.Array.CreateInstance(Item.GetType(), Size); > + } else { > + arr = new object[Size]; > + } > + arr.SetValue(Item, IndexToSet); > + return arr; > +} > + > +public static System.Array > +ML_array_resize(System.Array arr0, int Size, object Item) > +{ > + if (Size == 0) { > + return null; > + } > + if (arr0 == null) { > + return ML_new_array(Size, Item); > + } > + if (arr0.Length == Size) { > + return arr0; > + } > + > + int OldSize = arr0.Length; > + System.Array arr; > + if (Item is int) { > + int[] tmp = (int[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is uint) { > + uint[] tmp = (uint[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is sbyte) { > + sbyte[] tmp = (sbyte[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is byte) { > + byte[] tmp = (byte[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is short) { > + short[] tmp = (short[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is ushort) { > + ushort[] tmp = (ushort[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is long) { > + long[] tmp = (long[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is ulong) { > + ulong[] tmp = (ulong[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is double) { > + double[] tmp = (double[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is char) { > + char[] tmp = (char[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else if (Item is bool) { > + bool[] tmp = (bool[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } else { > + object[] tmp = (object[]) arr0; > + System.Array.Resize(ref tmp, Size); > + arr = tmp; > + } > + for (int i = OldSize; i < Size; i++) { > + arr.SetValue(Item, i); > + } > + return arr; > +} > + > +public static System.Array > +ML_shrink_array(System.Array arr, int Size) > +{ > + if (arr == null) { > + return null; > + } > + > + // We need to use Item here to determine the type instead of arr itself > + // since both 'arr is int[]' and 'arr is uint[]' evaluate to true; > + // similarly for the other integer types. (That behaviour is due to an > + // inconsistency between the covariance of value-typed arrays in C# and > + // the CLR.) > + object Item = arr.GetValue(0); > + if (Item is int) { > + int[] tmp = (int[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is uint) { > + uint[] tmp = (uint[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is sbyte) { > + sbyte[] tmp = (sbyte[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is byte) { > + byte[] tmp = (byte[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is short) { > + short[] tmp = (short[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is ushort) { > + ushort[] tmp = (ushort[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is long) { > + long[] tmp = (long[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is ulong) { > + ulong[] tmp = (ulong[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is double) { > + double[] tmp = (double[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is char) { > + char[] tmp = (char[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else if (Item is bool) { > + bool[] tmp = (bool[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } else { > + object[] tmp = (object[]) arr; > + System.Array.Resize(ref tmp, Size); > + return tmp; > + } > +} > +"). > + > +:- pragma foreign_code("Java", " > +public static Object > +ML_new_array(int Size, Object Item, boolean fill) > +{ > + if (Size == 0) { > + return null; > + } > + if (Item instanceof Integer) { > + int[] as = new int[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Integer) Item); > + } > + return as; > + } > + if (Item instanceof Double) { > + double[] as = new double[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Double) Item); > + } > + return as; > + } > + if (Item instanceof Character) { > + char[] as = new char[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Character) Item); > + } > + return as; > + } > + if (Item instanceof Boolean) { > + boolean[] as = new boolean[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Boolean) Item); > + } > + return as; > + } > + if (Item instanceof Byte) { > + byte[] as = new byte[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Byte) Item); > + } > + return as; > + } > + if (Item instanceof Short) { > + short[] as = new short[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Short) Item); > + } > + return as; > + } > + if (Item instanceof Long) { > + long[] as = new long[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Long) Item); > + } > + return as; > + } > + if (Item instanceof Float) { > + float[] as = new float[Size]; > + if (fill) { > + java.util.Arrays.fill(as, (Float) Item); > + } > + return as; > + } > + Object[] as = new Object[Size]; > + if (fill) { > + java.util.Arrays.fill(as, Item); > + } > + return as; > +} > + > +public static Object > +ML_unsafe_new_array(int Size, Object Item, int IndexToSet) > +{ > + if (Item instanceof Integer) { > + int[] as = new int[Size]; > + as[IndexToSet] = (Integer) Item; > + return as; > + } > + if (Item instanceof Double) { > + double[] as = new double[Size]; > + as[IndexToSet] = (Double) Item; > + return as; > + } > + if (Item instanceof Character) { > + char[] as = new char[Size]; > + as[IndexToSet] = (Character) Item; > + return as; > + } > + if (Item instanceof Boolean) { > + boolean[] as = new boolean[Size]; > + as[IndexToSet] = (Boolean) Item; > + return as; > + } > + if (Item instanceof Byte) { > + byte[] as = new byte[Size]; > + as[IndexToSet] = (Byte) Item; > + return as; > + } > + if (Item instanceof Short) { > + short[] as = new short[Size]; > + as[IndexToSet] = (Short) Item; > + return as; > + } > + if (Item instanceof Long) { > + long[] as = new long[Size]; > + as[IndexToSet] = (Long) Item; > + return as; > + } > + if (Item instanceof Float) { > + float[] as = new float[Size]; > + as[IndexToSet] = (Float) Item; > + return as; > + } > + Object[] as = new Object[Size]; > + as[IndexToSet] = Item; > + return as; > +} > + > +public static int > +ML_array_size(Object Array) > +{ > + if (Array == null) { > + return 0; > + } else if (Array instanceof int[]) { > + return ((int[]) Array).length; > + } else if (Array instanceof double[]) { > + return ((double[]) Array).length; > + } else if (Array instanceof char[]) { > + return ((char[]) Array).length; > + } else if (Array instanceof boolean[]) { > + return ((boolean[]) Array).length; > + } else if (Array instanceof byte[]) { > + return ((byte[]) Array).length; > + } else if (Array instanceof short[]) { > + return ((short[]) Array).length; > + } else if (Array instanceof long[]) { > + return ((long[]) Array).length; > + } else if (Array instanceof float[]) { > + return ((float[]) Array).length; > + } else { > + return ((Object[]) Array).length; > + } > +} > + > +public static Object > +ML_array_resize(Object Array0, int Size, Object Item) > +{ > + if (Size == 0) { > + return null; > + } > + if (Array0 == null) { > + return ML_new_array(Size, Item, true); > + } > + if (ML_array_size(Array0) == Size) { > + return Array0; > + } > + if (Array0 instanceof int[]) { > + int[] arr0 = (int[]) Array0; > + int[] Array = new int[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Integer) Item; > + } > + return Array; > + } > + if (Array0 instanceof double[]) { > + double[] arr0 = (double[]) Array0; > + double[] Array = new double[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Double) Item; > + } > + return Array; > + } > + if (Array0 instanceof char[]) { > + char[] arr0 = (char[]) Array0; > + char[] Array = new char[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Character) Item; > + } > + return Array; > + } > + if (Array0 instanceof boolean[]) { > + boolean[] arr0 = (boolean[]) Array0; > + boolean[] Array = new boolean[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Boolean) Item; > + } > + return Array; > + } > + if (Array0 instanceof byte[]) { > + byte[] arr0 = (byte[]) Array0; > + byte[] Array = new byte[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Byte) Item; > + } > + return Array; > + } > + if (Array0 instanceof short[]) { > + short[] arr0 = (short[]) Array0; > + short[] Array = new short[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Short) Item; > + } > + return Array; > + } > + if (Array0 instanceof long[]) { > + long[] arr0 = (long[]) Array0; > + long[] Array = new long[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Long) Item; > + } > + return Array; > + } > + if (Array0 instanceof float[]) { > + float[] arr0 = (float[]) Array0; > + float[] Array = new float[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = (Float) Item; > + } > + return Array; > + } else { > + Object[] arr0 = (Object[]) Array0; > + Object[] Array = new Object[Size]; > + > + System.arraycopy(arr0, 0, Array, 0, Math.min(arr0.length, Size)); > + for (int i = arr0.length; i < Size; i++) { > + Array[i] = Item; > + } > + return Array; > + } > +} > + > +public static Object > +ML_array_fill(Object array, int fromIndex, int toIndex, Object Item) > +{ > + if (array == null) { > + return null; > + } > + > + if (array instanceof int[]) { > + java.util.Arrays.fill(((int []) array), fromIndex, toIndex, > + (Integer) Item); > + } else if (array instanceof double[]) { > + java.util.Arrays.fill(((double []) array), fromIndex, toIndex, > + (Double) Item); > + } else if (array instanceof byte[]) { > + java.util.Arrays.fill(((byte []) array), fromIndex, toIndex, > + (Byte) Item); > + } else if (array instanceof short[]) { > + java.util.Arrays.fill(((short []) array), fromIndex, toIndex, > + (Short) Item); > + } else if (array instanceof long[]) { > + java.util.Arrays.fill(((long []) array), fromIndex, toIndex, > + (Long) Item); > + } else if (array instanceof char[]) { > + java.util.Arrays.fill(((char []) array), fromIndex, toIndex, > + (Character) Item); > + } else if (array instanceof boolean[]) { > + java.util.Arrays.fill(((boolean []) array), fromIndex, toIndex, > + (Boolean) Item); > + } else if (array instanceof float[]) { > + java.util.Arrays.fill(((float []) array), fromIndex, toIndex, > + (Float) Item); > + } else { > + java.util.Arrays.fill(((Object []) array), fromIndex, toIndex, Item); > + } > + return array; > +} > +"). > + > +init(N, X) = A :- > + array.init(N, X, A). > + > +init(Size, Item, Array) :- > + ( if Size < 0 then > + unexpected($pred, "negative size") > + else > + array.init_2(Size, Item, Array) > + ). > + > +:- pred init_2(int::in, T::in, array(T)::array_uo) is det. > + > +:- pragma foreign_proc("C", > + init_2(Size::in, Item::in, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, > + sharing(yes(int, T, array(T)), [ > + cel(Item, []) - cel(Array, [T]) > + ]) > + ], > +" > + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); > + ML_init_array(Array, Size, Item); > +"). > +:- pragma foreign_proc("C#", > + init_2(Size::in, Item::in, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Array = array.ML_new_array(Size, Item); > +"). > +:- pragma foreign_proc("Java", > + init_2(Size::in, Item::in, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Array = array.ML_new_array(Size, Item, true); > +"). > + > +make_empty_array = A :- > + array.make_empty_array(A). > + > +:- pragma foreign_proc("C", > + make_empty_array(Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, no_sharing], > +" > + ML_alloc_array(Array, 1, MR_ALLOC_ID); > + ML_init_array(Array, 0, 0); > +"). > +:- pragma foreign_proc("C#", > + make_empty_array(Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + // XXX A better solution than using the null pointer to represent > + // the empty array would be to create an array of size 0. However, > + // we need to determine the element type of the array before we can > + // do that. This could be done by examining the RTTI of the array > + // type and then using System.Type.GetType(""<mercury type>"") to > + // determine it. However constructing the <mercury type> string is > + // a non-trivial amount of work. > + Array = null; > +"). > +:- pragma foreign_proc("Java", > + make_empty_array(Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + // XXX as per C# > + Array = null; > +"). > + > +%---------------------------------------------------------------------------% > + > +generate(Size, GenFunc) = Array :- > + compare(Result, Size, 0), > + ( > + Result = (<), > + unexpected($pred, "negative size") > + ; > + Result = (=), > + make_empty_array(Array) > + ; > + Result = (>), > + FirstElem = GenFunc(0), > + Array0 = unsafe_init(Size, FirstElem, 0), > + Array = generate_2(1, Size, GenFunc, Array0) > + ). > + > +:- func unsafe_init(int::in, T::in, int::in) = (array(T)::array_uo) is det. > +:- pragma foreign_proc("C", > + unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo), > + [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail, > + does_not_affect_liveness], > +" > + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); > + > + // In debugging grades, we fill the array with the first element, > + // in case the return value of a call to this predicate is examined > + // in the debugger. > + #if defined(MR_EXEC_TRACE) > + ML_init_array(Array, Size, FirstElem); > + #else > + Array->size = Size; > + Array->elements[IndexToSet] = FirstElem; > + #endif > + > +"). > +:- pragma foreign_proc("C#", > + unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo), > + [promise_pure, will_not_call_mercury, thread_safe], > +" > + Array = array.ML_unsafe_new_array(Size, FirstElem, IndexToSet); > +"). > +:- pragma foreign_proc("Java", > + unsafe_init(Size::in, FirstElem::in, IndexToSet::in) = (Array::array_uo), > + [promise_pure, will_not_call_mercury, thread_safe], > +" > + Array = array.ML_unsafe_new_array(Size, FirstElem, IndexToSet); > +"). > + > +:- func generate_2(int::in, int::in, (func(int) = T)::in, array(T)::array_di) > + = (array(T)::array_uo) is det. > + > +generate_2(Index, Size, GenFunc, !.Array) = !:Array :- > + ( if Index < Size then > + Elem = GenFunc(Index), > + array.unsafe_set(Index, Elem, !Array), > + !:Array = generate_2(Index + 1, Size, GenFunc, !.Array) > + else > + true > + ). > + > +generate_foldl(Size, GenPred, Array, !Acc) :- > + compare(Result, Size, 0), > + ( > + Result = (<), > + unexpected($pred, "negative size") > + ; > + Result = (=), > + make_empty_array(Array) > + ; > + Result = (>), > + GenPred(0, FirstElem, !Acc), > + Array0 = unsafe_init(Size, FirstElem, 0), > + generate_foldl_2(1, Size, GenPred, Array0, Array, !Acc) > + ). > + > +:- pred generate_foldl_2(int, int, pred(int, T, A, A), > + array(T), array(T), A, A). > +:- mode generate_foldl_2(in, in, in(pred(in, out, in, out) is det), > + array_di, array_uo, in, out) is det. > +:- mode generate_foldl_2(in, in, in(pred(in, out, mdi, muo) is det), > + array_di, array_uo, mdi, muo) is det. > +:- mode generate_foldl_2(in, in, in(pred(in, out, di, uo) is det), > + array_di, array_uo, di, uo) is det. > +:- mode generate_foldl_2(in, in, in(pred(in, out, in, out) is semidet), > + array_di, array_uo, in, out) is semidet. > +:- mode generate_foldl_2(in, in, in(pred(in, out, mdi, muo) is semidet), > + array_di, array_uo, mdi, muo) is semidet. > +:- mode generate_foldl_2(in, in, in(pred(in, out, di, uo) is semidet), > + array_di, array_uo, di, uo) is semidet. > + > +generate_foldl_2(Index, Size, GenPred, !Array, !Acc) :- > + ( if Index < Size then > + GenPred(Index, Elem, !Acc), > + array.unsafe_set(Index, Elem, !Array), > + generate_foldl_2(Index + 1, Size, GenPred, !Array, !Acc) > + else > + true > + ). > + > +%---------------------------------------------------------------------------% > + > +min(A) = N :- > + array.min(A, N). > + > +:- pragma foreign_proc("C", > + min(Array::in, Min::out), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, no_sharing], > +" > + // Array not used. > + Min = 0; > +"). > + > +:- pragma foreign_proc("C#", > + min(_Array::in, Min::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + // Array not used. > + Min = 0; > +"). > + > + > +:- pragma foreign_proc("Java", > + min(_Array::in, Min::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + // Array not used. > + Min = 0; > +"). > + > +max(A) = N :- > + array.max(A, N). > + > +:- pragma foreign_proc("C", > + max(Array::in, Max::out), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, no_sharing], > +" > + Max = Array->size - 1; > +"). > +:- pragma foreign_proc("C#", > + max(Array::in, Max::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + if (Array != null) { > + Max = Array.Length - 1; > + } else { > + Max = -1; > + } > +"). > + > +:- pragma foreign_proc("Java", > + max(Array::in, Max::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + if (Array != null) { > + Max = array.ML_array_size(Array) - 1; > + } else { > + Max = -1; > + } > +"). > + > +bounds(Array, Min, Max) :- > + array.min(Array, Min), > + array.max(Array, Max). > + > +%---------------------------------------------------------------------------% > + > +size(A) = N :- > + array.size(A, N). > + > +:- pragma foreign_proc("C", > + size(Array::in, Max::out), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, no_sharing], > +" > + Max = Array->size; > +"). > + > +:- pragma foreign_proc("C#", > + size(Array::in, Max::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + if (Array != null) { > + Max = Array.Length; > + } else { > + Max = 0; > + } > +"). > + > +:- pragma foreign_proc("Java", > + size(Array::in, Max::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Max = jmercury.array.ML_array_size(Array); > +"). > + > +%---------------------------------------------------------------------------% > + > +in_bounds(Array, Index) :- > + array.bounds(Array, Min, Max), > + Min =< Index, Index =< Max. > + > +is_empty(Array) :- > + array.size(Array, 0). > + > +semidet_set(Index, Item, !Array) :- > + ( if array.in_bounds(!.Array, Index) then > + array.unsafe_set(Index, Item, !Array) > + else > + fail > + ). > + > +semidet_slow_set(Index, Item, !Array) :- > + ( if array.in_bounds(!.Array, Index) then > + array.slow_set(Index, Item, !Array) > + else > + fail > + ). > + > +slow_set(!.Array, N, X) = !:Array :- > + array.slow_set(N, X, !Array). > + > +slow_set(Index, Item, !Array) :- > + array.copy(!Array), > + array.set(Index, Item, !Array). > + > +%---------------------------------------------------------------------------% > + > +elem(Index, Array) = array.lookup(Array, Index). > + > +unsafe_elem(Index, Array) = Elem :- > + array.unsafe_lookup(Array, Index, Elem). > + > +lookup(Array, N) = X :- > + array.lookup(Array, N, X). > + > +lookup(Array, Index, Item) :- > + ( if > + bounds_checks, > + not array.in_bounds(Array, Index) > + then > + out_of_bounds_error(Array, Index, "array.lookup") > + else > + array.unsafe_lookup(Array, Index, Item) > + ). > + > +semidet_lookup(Array, Index, Item) :- > + ( if array.in_bounds(Array, Index) then > + array.unsafe_lookup(Array, Index, Item) > + else > + fail > + ). > + > +:- pragma foreign_proc("C", > + unsafe_lookup(Array::in, Index::in, Item::out), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, > + sharing(yes(array(T), int, T), [ > + cel(Array, [T]) - cel(Item, []) > + ]) > + ], > +" > + Item = Array->elements[Index]; > +"). > + > +:- pragma foreign_proc("C#", > + unsafe_lookup(Array::in, Index::in, Item::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +"{ > + Item = Array.GetValue(Index); > +}"). > + > +:- pragma foreign_proc("Java", > + unsafe_lookup(Array::in, Index::in, Item::out), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + if (Array instanceof int[]) { > + Item = ((int[]) Array)[Index]; > + } else if (Array instanceof double[]) { > + Item = ((double[]) Array)[Index]; > + } else if (Array instanceof char[]) { > + Item = ((char[]) Array)[Index]; > + } else if (Array instanceof boolean[]) { > + Item = ((boolean[]) Array)[Index]; > + } else if (Array instanceof byte[]) { > + Item = ((byte[]) Array)[Index]; > + } else if (Array instanceof short[]) { > + Item = ((short[]) Array)[Index]; > + } else if (Array instanceof long[]) { > + Item = ((long[]) Array)[Index]; > + } else if (Array instanceof float[]) { > + Item = ((float[]) Array)[Index]; > + } else { > + Item = ((Object[]) Array)[Index]; > + } > +"). > + > +%---------------------------------------------------------------------------% > + > +'elem :='(Index, Array, Value) = array.set(Array, Index, Value). > + > +set(A1, N, X) = A2 :- > + array.set(N, X, A1, A2). > + > +set(Index, Item, !Array) :- > + ( if > + bounds_checks, > + not array.in_bounds(!.Array, Index) > + then > + out_of_bounds_error(!.Array, Index, "array.set") > + else > + array.unsafe_set(Index, Item, !Array) > + ). > + > +'unsafe_elem :='(Index, !.Array, Value) = !:Array :- > + array.unsafe_set(Index, Value, !Array). > + > +:- pragma foreign_proc("C", > + unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, > + sharing(yes(int, T, array(T), array(T)), [ > + cel(Array0, []) - cel(Array, []), > + cel(Item, []) - cel(Array, [T]) > + ]) > + ], > +" > + Array0->elements[Index] = Item; // destructive update! > + Array = Array0; > +"). > + > +:- pragma foreign_proc("C#", > + unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +"{ > + Array0.SetValue(Item, Index); // destructive update! > + Array = Array0; > +}"). > + > +:- pragma foreign_proc("Java", > + unsafe_set(Index::in, Item::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + if (Array0 instanceof int[]) { > + ((int[]) Array0)[Index] = (Integer) Item; > + } else if (Array0 instanceof double[]) { > + ((double[]) Array0)[Index] = (Double) Item; > + } else if (Array0 instanceof char[]) { > + ((char[]) Array0)[Index] = (Character) Item; > + } else if (Array0 instanceof boolean[]) { > + ((boolean[]) Array0)[Index] = (Boolean) Item; > + } else if (Array0 instanceof byte[]) { > + ((byte[]) Array0)[Index] = (Byte) Item; > + } else if (Array0 instanceof short[]) { > + ((short[]) Array0)[Index] = (Short) Item; > + } else if (Array0 instanceof long[]) { > + ((long[]) Array0)[Index] = (Long) Item; > + } else if (Array0 instanceof float[]) { > + ((float[]) Array0)[Index] = (Float) Item; > + } else { > + ((Object[]) Array0)[Index] = Item; > + } > + Array = Array0; // destructive update! > +"). > + > +%---------------------------------------------------------------------------% > + > +% lower bounds other than zero are not supported > +% % array.resize takes an array and new lower and upper bounds. > +% % the array is expanded or shrunk at each end to make it fit > +% % the new bounds. > +% :- pred array.resize(array(T), int, int, array(T)). > +% :- mode array.resize(in, in, in, out) is det. > + > +:- pragma foreign_decl("C", " > +extern void > +ML_resize_array(MR_ArrayPtr new_array, MR_ArrayPtr old_array, > + MR_Integer array_size, MR_Word item); > +"). > + > +:- pragma foreign_code("C", " > +// The caller is responsible for allocating the storage for the new array. > +// This routine does the job of copying the old array elements to the > +// new array, initializing any additional elements in the new array, > +// and deallocating the old array. > +void > +ML_resize_array(MR_ArrayPtr array, MR_ArrayPtr old_array, > + MR_Integer array_size, MR_Word item) > +{ > + MR_Integer i; > + MR_Integer elements_to_copy; > + > + elements_to_copy = old_array->size; > + if (elements_to_copy > array_size) { > + elements_to_copy = array_size; > + } > + > + array->size = array_size; > + for (i = 0; i < elements_to_copy; i++) { > + array->elements[i] = old_array->elements[i]; > + } > + for (; i < array_size; i++) { > + array->elements[i] = item; > + } > + > + // Since the mode on the old array is `array_di', it is safe to > + // deallocate the storage for it. > +#ifdef MR_CONSERVATIVE_GC > + MR_GC_free_attrib(old_array); > +#endif > +} > +"). > + > +resize(!.Array, N, X) = !:Array :- > + array.resize(N, X, !Array). > + > +resize(N, X, !Array) :- > + ( if N < 0 then > + unexpected($pred, "cannot resize to a negative size") > + else > + do_resize(N, X, !Array) > + ). > + > +:- pred do_resize(int, T, array(T), array(T)). > +:- mode do_resize(in, in, array_di, array_uo) is det. > + > +:- pragma foreign_proc("C", > + do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, > + sharing(yes(int, T, array(T), array(T)), [ > + cel(Array0, []) - cel(Array, []), > + cel(Item, []) - cel(Array, [T]) > + ]) > + ], > +" > + if ((Array0)->size == Size) { > + Array = Array0; > + } else { > + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); > + ML_resize_array(Array, Array0, Size, Item); > + } > +"). > + > +:- pragma foreign_proc("C#", > + do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Array = array.ML_array_resize(Array0, Size, Item); > +"). > + > +:- pragma foreign_proc("Java", > + do_resize(Size::in, Item::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Array = jmercury.array.ML_array_resize(Array0, Size, Item); > +"). > + > +%---------------------------------------------------------------------------% > + > +:- pragma foreign_decl("C", " > +extern void > +ML_shrink_array(MR_ArrayPtr array, MR_ArrayPtr old_array, > + MR_Integer array_size); > +"). > + > +:- pragma foreign_code("C", " > +// The caller is responsible for allocating the storage for the new array. > +// This routine does the job of copying the old array elements to the > +// new array and deallocating the old array. > +void > +ML_shrink_array(MR_ArrayPtr array, MR_ArrayPtr old_array, > + MR_Integer array_size) > +{ > + MR_Integer i; > + > + array->size = array_size; > + for (i = 0; i < array_size; i++) { > + array->elements[i] = old_array->elements[i]; > + } > + > + // Since the mode on the old array is `array_di', it is safe to > + // deallocate the storage for it. > +#ifdef MR_CONSERVATIVE_GC > + MR_GC_free_attrib(old_array); > +#endif > +} > +"). > + > +shrink(!.Array, N) = !:Array :- > + array.shrink(N, !Array). > + > +shrink(Size, !Array) :- > + OldSize = array.size(!.Array), > + ( if Size < 0 then > + unexpected($pred, "cannot shrink to a negative size") > + else if Size > OldSize then > + unexpected($pred, "cannot shrink to a larger size") > + else if Size = OldSize then > + true > + else > + array.shrink_2(Size, !Array) > + ). > + > +:- pred shrink_2(int::in, array(T)::array_di, array(T)::array_uo) is det. > + > +:- pragma foreign_proc("C", > + shrink_2(Size::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, > + sharing(yes(int, array(T), array(T)), [ > + cel(Array0, []) - cel(Array, []) > + ]) > + ], > +" > + ML_alloc_array(Array, Size + 1, MR_ALLOC_ID); > + ML_shrink_array(Array, Array0, Size); > +"). > + > +:- pragma foreign_proc("C#", > + shrink_2(Size::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Array = array.ML_shrink_array(Array0, Size); > +"). > + > +:- pragma foreign_proc("Java", > + shrink_2(Size::in, Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + if (Array0 == null) { > + Array = null; > + } else if (Array0 instanceof int[]) { > + Array = new int[Size]; > + } else if (Array0 instanceof double[]) { > + Array = new double[Size]; > + } else if (Array0 instanceof byte[]) { > + Array = new byte[Size]; > + } else if (Array0 instanceof short[]) { > + Array = new short[Size]; > + } else if (Array0 instanceof long[]) { > + Array = new long[Size]; > + } else if (Array0 instanceof char[]) { > + Array = new char[Size]; > + } else if (Array0 instanceof float[]) { > + Array = new float[Size]; > + } else if (Array0 instanceof boolean[]) { > + Array = new boolean[Size]; > + } else { > + Array = new Object[Size]; > + } > + > + if (Array != null) { > + System.arraycopy(Array0, 0, Array, 0, Size); > + } > +"). > + > +%---------------------------------------------------------------------------% > + > +fill(Item, !Array) :- > + array.bounds(!.Array, Min, Max), > + do_fill_range(Item, Min, Max, !Array). > + > +fill_range(Item, Lo, Hi, !Array) :- > + ( if Lo > Hi then > + unexpected($pred, "empty range") > + else if not in_bounds(!.Array, Lo) then > + arg_out_of_bounds_error(!.Array, "second", "fill_range", Lo) > + else if not in_bounds(!.Array, Hi) then > + arg_out_of_bounds_error(!.Array, "third", "fill_range", Hi) > + else > + do_fill_range(Item, Lo, Hi, !Array) > + ). > + > +%---------------------------------------------------------------------------% > + > +:- pred do_fill_range(T::in, int::in, int::in, > + array(T)::array_di, array(T)::array_uo) is det. > + > +:- pragma foreign_proc("Java", > + do_fill_range(Item::in, Lo::in, Hi::in, > + Array0::array_di, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Array = jmercury.array.ML_array_fill(Array0, Lo, Hi + 1, Item); > +"). > + > +do_fill_range(Item, Lo, Hi, !Array) :- > + ( if Lo =< Hi then > + array.unsafe_set(Lo, Item, !Array), > + do_fill_range(Item, Lo + 1, Hi, !Array) > + else > + true > + ). > + > +%---------------------------------------------------------------------------% > + > +:- pragma foreign_decl("C", " > +extern void > +ML_copy_array(MR_ArrayPtr array, MR_ConstArrayPtr old_array); > +"). > + > +:- pragma foreign_code("C", " > +// The caller is responsible for allocating the storage for the new array. > +// This routine does the job of copying the array elements. > +void > +ML_copy_array(MR_ArrayPtr array, MR_ConstArrayPtr old_array) > +{ > + // Any changes to this function will probably also require changes to > + // - array.append below, and > + // - MR_deep_copy() in runtime/mercury_deep_copy.[ch]. > + > + MR_Integer i; > + MR_Integer array_size; > + > + array_size = old_array->size; > + array->size = array_size; > + for (i = 0; i < array_size; i++) { > + array->elements[i] = old_array->elements[i]; > + } > +} > +"). > + > +copy(A1) = A2 :- > + array.copy(A1, A2). > + > +:- pragma foreign_proc("C", > + copy(Array0::in, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, > + sharing(yes(array(T), array(T)), [ > + cel(Array0, [T]) - cel(Array, [T]) > + ]) > + ], > +" > + ML_alloc_array(Array, Array0->size + 1, MR_ALLOC_ID); > + ML_copy_array(Array, (MR_ConstArrayPtr) Array0); > +"). > + > +:- pragma foreign_proc("C#", > + copy(Array0::in, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + Array = (System.Array) Array0.Clone(); > +"). > + > +:- pragma foreign_proc("Java", > + copy(Array0::in, Array::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe], > +" > + int Size; > + > + if (Array0 == null) { > + Array = null; > + Size = 0; > + } else if (Array0 instanceof int[]) { > + Size = ((int[]) Array0).length; > + Array = new int[Size]; > + } else if (Array0 instanceof double[]) { > + Size = ((double[]) Array0).length; > + Array = new double[Size]; > + } else if (Array0 instanceof byte[]) { > + Size = ((byte[]) Array0).length; > + Array = new byte[Size]; > + } else if (Array0 instanceof short[]) { > + Size = ((short[]) Array0).length; > + Array = new short[Size]; > + } else if (Array0 instanceof long[]) { > + Size = ((long[]) Array0).length; > + Array = new long[Size]; > + } else if (Array0 instanceof char[]) { > + Size = ((char[]) Array0).length; > + Array = new char[Size]; > + } else if (Array0 instanceof float[]) { > + Size = ((float[]) Array0).length; > + Array = new float[Size]; > + } else if (Array0 instanceof boolean[]) { > + Size = ((boolean[]) Array0).length; > + Array = new boolean[Size]; > + } else { > + Size = ((Object[]) Array0).length; > + Array = new Object[Size]; > + } > + > + if (Array != null) { > + System.arraycopy(Array0, 0, Array, 0, Size); > + } > +"). > + > +%---------------------------------------------------------------------------% > + > +array(List) = Array :- > + array.from_list(List, Array). > + > +from_list(List) = Array :- > + array.from_list(List, Array). > + > +from_list([], Array) :- > + array.make_empty_array(Array). > +from_list(List, Array) :- > + List = [Head | Tail], > + list.length(List, Len), > + Array0 = array.unsafe_init(Len, Head, 0), > + array.unsafe_insert_items(Tail, 1, Array0, Array). > + > +%---------------------------------------------------------------------------% > + > +:- pred unsafe_insert_items(list(T)::in, int::in, > + array(T)::array_di, array(T)::array_uo) is det. > + > +unsafe_insert_items([], _N, !Array). > +unsafe_insert_items([Head | Tail], N, !Array) :- > + unsafe_set(N, Head, !Array), > + unsafe_insert_items(Tail, N + 1, !Array). > + > +%---------------------------------------------------------------------------% > + > +from_reverse_list([]) = Array :- > + array.make_empty_array(Array). > +from_reverse_list(RevList) = Array :- > + RevList = [Head | Tail], > + list.length(RevList, Len), > + Array0 = array.unsafe_init(Len, Head, Len - 1), > + unsafe_insert_items_reverse(Tail, Len - 2, Array0, Array). > + > +:- pred unsafe_insert_items_reverse(list(T)::in, int::in, > + array(T)::array_di, array(T)::array_uo) is det. > + > +unsafe_insert_items_reverse([], _, !Array). > +unsafe_insert_items_reverse([Head | Tail], N, !Array) :- > + unsafe_set(N, Head, !Array), > + unsafe_insert_items_reverse(Tail, N - 1, !Array). > + > +%---------------------------------------------------------------------------% > + > +to_list(Array) = List :- > + to_list(Array, List). > + > +to_list(Array, List) :- > + ( if is_empty(Array) then > + List = [] > + else > + bounds(Array, Low, High), > + fetch_items(Array, Low, High, List) > + ). > + > +%---------------------------------------------------------------------------% > + > +fetch_items(Array, Low, High) = List :- > + fetch_items(Array, Low, High, List). > + > +fetch_items(Array, Low, High, List) :- > + ( if High < Low then > + % If High is less than Low, then there cannot be any array indexes > + % within the range Low -> High (inclusive). This can happen when > + % calling to_list/2 on the empty array, or when iterative over > + % consecutive contiguous regions of an array. (For an example of > + % the latter, see ip_get_goals_{before,after} and their callers > + % in the deep_profiler directory.) > + List = [] > + else if not in_bounds(Array, Low) then > + arg_out_of_bounds_error(Array, "second", "fetch_items", Low) > + else if not in_bounds(Array, High) then > + arg_out_of_bounds_error(Array, "third", "fetch_items", High) > + else > + List = do_foldr_func(func(X, Xs) = [X | Xs], Array, [], Low, High) > + ). > + > +%---------------------------------------------------------------------------% > + > +map(F, A1) = A2 :- > + P = (pred(X::in, Y::out) is det :- Y = F(X)), > + array.map(P, A1, A2). > + > +map(Closure, OldArray, NewArray) :- > + ( if array.semidet_lookup(OldArray, 0, Elem0) then > + array.size(OldArray, Size), > + Closure(Elem0, Elem), > + NewArray0 = unsafe_init(Size, Elem, 0), > + array.map_2(1, Size, Closure, OldArray, NewArray0, NewArray) > + else > + array.make_empty_array(NewArray) > + ). > + > +:- pred map_2(int::in, int::in, pred(T1, T2)::in(pred(in, out) is det), > + array(T1)::in, array(T2)::array_di, array(T2)::array_uo) is det. > + > +map_2(N, Size, Closure, OldArray, !NewArray) :- > + ( if N >= Size then > + true > + else > + array.unsafe_lookup(OldArray, N, OldElem), > + Closure(OldElem, NewElem), > + array.unsafe_set(N, NewElem, !NewArray), > + map_2(N + 1, Size, Closure, OldArray, !NewArray) > + ). > + > +%---------------------------------------------------------------------------% > + > +swap(I, J, !Array) :- > + ( if not in_bounds(!.Array, I) then > + arg_out_of_bounds_error(!.Array, "first", "array.swap", I) > + else if not in_bounds(!.Array, J) then > + arg_out_of_bounds_error(!.Array, "second", "array.swap", J) > + else > + unsafe_swap(I, J, !Array) > + ). > + > +unsafe_swap(I, J, !Array) :- > + array.unsafe_lookup(!.Array, I, IVal), > + array.unsafe_lookup(!.Array, J, JVal), > + array.unsafe_set(I, JVal, !Array), > + array.unsafe_set(J, IVal, !Array). > + > +%---------------------------------------------------------------------------% > + > +member(A, X) :- > + nondet_int_in_range(array.min(A), array.max(A), N), > + array.unsafe_lookup(A, N, X). > + > +%---------------------------------------------------------------------------% > + > + % array.sort/1 has type specialised versions for arrays of ints and strings > + % on the expectation that these constitute the common case and are hence > + % worth providing a fast-path. > + % > + % Experiments indicate that type specialisation improves the speed of > + % array.sort/1 by about 30-40%. > + % > +:- pragma type_spec(array.sort/1, T = int). > +:- pragma type_spec(array.sort/1, T = string). > + > +sort(A) = samsort_subarray(A, array.min(A), array.max(A)). > + > +:- pragma no_inline(array.sort_fix_2014/0). > + > +sort_fix_2014. > + > +%---------------------------------------------------------------------------% > + > +binary_search(A, SearchX, I) :- > + array.binary_search(ordering, A, SearchX, I). > + > +binary_search(Cmp, A, SearchX, I) :- > + Lo = 0, > + Hi = array.size(A) - 1, > + binary_search_loop(Cmp, A, SearchX, Lo, Hi, I). > + > +:- pred binary_search_loop(comparison_func(T)::in, array(T)::array_ui, > + T::in, int::in, int::in, int::out) is semidet. > + > +binary_search_loop(Cmp, A, SearchX, Lo, Hi, I) :- > + % loop invariant: if SearchX is anywhere in A[0] .. A[array.size(A)-1], > + % then it is in A[Lo] .. A[Hi]. > + Lo =< Hi, > + % We calculate Mid this way to avoid overflow. > + % The right shift by one bit is a fast implementation of division by 2. > + Mid = Lo + ((Hi - Lo) `unchecked_right_shift` 1), > + array.unsafe_lookup(A, Mid, MidX), > + O = Cmp(MidX, SearchX), > + ( > + O = (>), > + binary_search_loop(Cmp, A, SearchX, Lo, Mid - 1, I) > + ; > + O = (=), > + I = Mid > + ; > + O = (<), > + binary_search_loop(Cmp, A, SearchX, Mid + 1, Hi, I) > + ). > + > +%---------------------------------------------------------------------------% > + > +approx_binary_search(A, SearchX, I) :- > + approx_binary_search(ordering, A, SearchX, I). > + > +approx_binary_search(Cmp, A, SearchX, I) :- > + Lo = 0, > + Hi = array.size(A) - 1, > + approx_binary_search_loop(Cmp, A, SearchX, Lo, Hi, I). > + > +:- pred approx_binary_search_loop(comparison_func(T)::in, array(T)::array_ui, > + T::in, int::in, int::in, int::out) is semidet. > + > +approx_binary_search_loop(Cmp, A, SearchX, Lo, Hi, I) :- > + % loop invariant: if SearchX is anywhere in A[0] .. A[array.size(A)-1], > + % then it is in A[Lo] .. A[Hi]. > + Lo =< Hi, > + % We calculate Mid this way to avoid overflow. > + % The right shift by one bit is a fast implementation of division by 2. > + Mid = Lo + ((Hi - Lo) `unchecked_right_shift` 1), > + array.unsafe_lookup(A, Mid, MidX), > + O = Cmp(MidX, SearchX), > + ( > + O = (>), > + approx_binary_search_loop(Cmp, A, SearchX, Lo, Mid - 1, I) > + ; > + O = (=), > + I = Mid > + ; > + O = (<), > + ( if > + ( if Mid < Hi then > + % We get here only if Mid + 1 cannot exceed Hi, > + % so the array access is safe. > + array.unsafe_lookup(A, Mid + 1, MidP1X), > + (<) = Cmp(SearchX, MidP1X) > + else > + Mid = Hi > + ) > + then > + I = Mid > + else > + approx_binary_search_loop(Cmp, A, SearchX, Mid + 1, Hi, I) > + ) > + ). > + > +%---------------------------------------------------------------------------% > + > +append(A, B) = C :- > + SizeA = array.size(A), > + SizeB = array.size(B), > + SizeC = SizeA + SizeB, > + ( if > + ( if SizeA > 0 then > + array.lookup(A, 0, InitElem) > + else if SizeB > 0 then > + array.lookup(B, 0, InitElem) > + else > + fail > + ) > + then > + C0 = array.init(SizeC, InitElem), > + copy_subarray(A, 0, SizeA - 1, 0, C0, C1), > + copy_subarray(B, 0, SizeB - 1, SizeA, C1, C) > + else > + C = array.make_empty_array > + ). > + > +:- pragma foreign_proc("C", > + append(ArrayA::in, ArrayB::in) = (ArrayC::array_uo), > + [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail, > + does_not_affect_liveness, > + sharing(yes(array(T), array(T), array(T)), [ > + cel(ArrayA, [T]) - cel(ArrayC, [T]), > + cel(ArrayB, [T]) - cel(ArrayC, [T]) > + ]) > + ], > +" > + MR_Integer sizeC; > + MR_Integer i; > + MR_Integer offset; > + > + sizeC = ArrayA->size + ArrayB->size; > + ML_alloc_array(ArrayC, sizeC + 1, MR_ALLOC_ID); > + > + ArrayC->size = sizeC; > + for (i = 0; i < ArrayA->size; i++) { > + ArrayC->elements[i] = ArrayA->elements[i]; > + } > + > + offset = ArrayA->size; > + for (i = 0; i < ArrayB->size; i++) { > + ArrayC->elements[offset + i] = ArrayB->elements[i]; > + } > +"). > + > +%---------------------------------------------------------------------------% > + > +random_permutation(A0, A, RS0, RS) :- > + Lo = array.min(A0), > + Hi = array.max(A0), > + Sz = array.size(A0), > + permutation_2(Lo, Lo, Hi, Sz, A0, A, RS0, RS). > + > +:- pred permutation_2(int::in, int::in, int::in, int::in, > + array(T)::array_di, array(T)::array_uo, > + random.supply::mdi, random.supply::muo) is det. > + > +permutation_2(I, Lo, Hi, Sz, !A, !RS) :- > + ( if I > Hi then > + true > + else > + random.random(R, !RS), > + J = Lo + (R `rem` Sz), > + swap_elems(I, J, !A), > + permutation_2(I + 1, Lo, Hi, Sz, !A, !RS) > + ). > + > +:- pred swap_elems(int::in, int::in, array(T)::array_di, array(T)::array_uo) > + is det. > + > +swap_elems(I, J, !A) :- > + array.lookup(!.A, I, XI), > + array.lookup(!.A, J, XJ), > + array.unsafe_set(I, XJ, !A), > + array.unsafe_set(J, XI, !A). > + > +%---------------------------------------------------------------------------% > + > +foldl(Fn, A, X) = > + do_foldl_func(Fn, A, X, array.min(A), array.max(A)). > + > +:- func do_foldl_func(func(T1, T2) = T2, array(T1), T2, int, int) = T2. > +%:- mode do_foldl_func(func(in, in) = out is det, array_ui, in, in, in) > +% = out is det. > +:- mode do_foldl_func(func(in, in) = out is det, in, in, in, in) = out is det. > +%:- mode do_foldl_func(func(in, di) = uo is det, array_ui, di, in, in) > +% = uo is det. > +:- mode do_foldl_func(func(in, di) = uo is det, in, di, in, in) = uo is det. > + > +do_foldl_func(Fn, A, X, I, Max) = > + ( if Max < I then > + X > + else > + do_foldl_func(Fn, A, Fn(A ^ unsafe_elem(I), X), I + 1, Max) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldl(P, A, !Acc) :- > + do_foldl_pred(P, A, array.min(A), array.max(A), !Acc). > + > +:- pred do_foldl_pred(pred(T1, T2, T2), array(T1), int, int, T2, T2). > +:- mode do_foldl_pred(pred(in, in, out) is det, in, in, in, in, out) is det. > +:- mode do_foldl_pred(pred(in, mdi, muo) is det, in, in, in, mdi, muo) is det. > +:- mode do_foldl_pred(pred(in, di, uo) is det, in, in, in, di, uo) is det. > +:- mode do_foldl_pred(pred(in, in, out) is semidet, in, in, in, in, out) > + is semidet. > +:- mode do_foldl_pred(pred(in, mdi, muo) is semidet, in, in, in, mdi, muo) > + is semidet. > +:- mode do_foldl_pred(pred(in, di, uo) is semidet, in, in, in, di, uo) > + is semidet. > + > +do_foldl_pred(P, A, I, Max, !Acc) :- > + ( if Max < I then > + true > + else > + P(A ^ unsafe_elem(I), !Acc), > + do_foldl_pred(P, A, I + 1, Max, !Acc) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldl2(P, A, !Acc1, !Acc2) :- > + do_foldl2(P, array.min(A), array.max(A), A, !Acc1, !Acc2). > + > +:- pred do_foldl2(pred(T1, T2, T2, T3, T3), int, int, array(T1), T2, T2, > + T3, T3). > +:- mode do_foldl2(pred(in, in, out, in, out) is det, in, in, in, in, out, > + in, out) is det. > +:- mode do_foldl2(pred(in, in, out, mdi, muo) is det, in, in, in, in, out, > + mdi, muo) is det. > +:- mode do_foldl2(pred(in, in, out, di, uo) is det, in, in, in, in, out, > + di, uo) is det. > +:- mode do_foldl2(pred(in, in, out, in, out) is semidet, in, in, in, in, out, > + in, out) is semidet. > +:- mode do_foldl2(pred(in, in, out, mdi, muo) is semidet, in, in, in, in, out, > + mdi, muo) is semidet. > +:- mode do_foldl2(pred(in, in, out, di, uo) is semidet, in, in, in, in, out, > + di, uo) is semidet. > + > +do_foldl2(P, I, Max, A, !Acc1, !Acc2) :- > + ( if Max < I then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2), > + do_foldl2(P, I + 1, Max, A, !Acc1, !Acc2) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldl3(P, A, !Acc1, !Acc2, !Acc3) :- > + do_foldl3(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3). > + > +:- pred do_foldl3(pred(T1, T2, T2, T3, T3, T4, T4), int, int, array(T1), > + T2, T2, T3, T3, T4, T4). > +:- mode do_foldl3(pred(in, in, out, in, out, in, out) is det, in, in, in, > + in, out, in, out, in, out) is det. > +:- mode do_foldl3(pred(in, in, out, in, out, mdi, muo) is det, in, in, in, > + in, out, in, out, mdi, muo) is det. > +:- mode do_foldl3(pred(in, in, out, in, out, di, uo) is det, in, in, in, > + in, out, in, out, di, uo) is det. > +:- mode do_foldl3(pred(in, in, out, in, out, in, out) is semidet, in, in, in, > + in, out, in, out, in, out) is semidet. > +:- mode do_foldl3(pred(in, in, out, in, out, mdi, muo) is semidet, in, in, in, > + in, out, in, out, mdi, muo) is semidet. > +:- mode do_foldl3(pred(in, in, out, in, out, di, uo) is semidet, in, in, in, > + in, out, in, out, di, uo) is semidet. > + > +do_foldl3(P, I, Max, A, !Acc1, !Acc2, !Acc3) :- > + ( if Max < I then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3), > + do_foldl3(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldl4(P, A, !Acc1, !Acc2, !Acc3, !Acc4) :- > + do_foldl4(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4). > + > +:- pred do_foldl4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), int, int, > + array(T1), T2, T2, T3, T3, T4, T4, T5, T5). > +:- mode do_foldl4(pred(in, in, out, in, out, in, out, in, out) is det, in, in, > + in, in, out, in, out, in, out, in, out) is det. > +:- mode do_foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is det, in, in, > + in, in, out, in, out, in, out, mdi, muo) is det. > +:- mode do_foldl4(pred(in, in, out, in, out, in, out, di, uo) is det, in, in, > + in, in, out, in, out, in, out, di, uo) is det. > +:- mode do_foldl4(pred(in, in, out, in, out, in, out, in, out) is semidet, > + in, in, in, in, out, in, out, in, out, in, out) is semidet. > +:- mode do_foldl4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, in, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode do_foldl4(pred(in, in, out, in, out, in, out, di, uo) is semidet, > + in, in, in, in, out, in, out, in, out, di, uo) is semidet. > + > +do_foldl4(P, I, Max, A, !Acc1, !Acc2, !Acc3, !Acc4) :- > + ( if Max < I then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4), > + do_foldl4(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3, !Acc4) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldl5(P, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- > + do_foldl5(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4, > + !Acc5). > + > +:- pred do_foldl5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), > + int, int, array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). > +:- mode do_foldl5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is det, > + in, in, in, in, out, in, out, in, out, in, out, in, out) is det. > +:- mode do_foldl5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, > + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is det. > +:- mode do_foldl5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, > + in, in, in, in, out, in, out, in, out, in, out, di, uo) is det. > +:- mode do_foldl5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, > + in, in, in, in, out, in, out, in, out, in, out, in, out) is semidet. > +:- mode do_foldl5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode do_foldl5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, > + in, in, in, in, out, in, out, in, out, in, out, di, uo) is semidet. > + > +do_foldl5(P, I, Max, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- > + ( if Max < I then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4, !Acc5), > + do_foldl5(P, I + 1, Max, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldr(Fn, A, X) = > + do_foldr_func(Fn, A, X, array.min(A), array.max(A)). > + > +:- func do_foldr_func(func(T1, T2) = T2, array(T1), T2, int, int) = T2. > +%:- mode do_foldr_func(func(in, in) = out is det, array_ui, in, in, in) > +% = out is det. > +:- mode do_foldr_func(func(in, in) = out is det, in, in, in, in) = out is det. > +%:- mode do_foldr_func(func(in, di) = uo is det, array_ui, di, in, in) > +% = uo is det. > +:- mode do_foldr_func(func(in, di) = uo is det, in, di, in, in) = uo is det. > + > +do_foldr_func(Fn, A, X, Min, I) = > + ( if I < Min then > + X > + else > + do_foldr_func(Fn, A, Fn(A ^ unsafe_elem(I), X), Min, I - 1) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldr(P, A, !Acc) :- > + do_foldr_pred(P, array.min(A), array.max(A), A, !Acc). > + > +:- pred do_foldr_pred(pred(T1, T2, T2), int, int, array(T1), T2, T2). > +:- mode do_foldr_pred(pred(in, in, out) is det, in, in, in, in, out) is det. > +:- mode do_foldr_pred(pred(in, mdi, muo) is det, in, in, in, mdi, muo) is det. > +:- mode do_foldr_pred(pred(in, di, uo) is det, in, in, in, di, uo) is det. > +:- mode do_foldr_pred(pred(in, in, out) is semidet, in, in, in, in, out) > + is semidet. > +:- mode do_foldr_pred(pred(in, mdi, muo) is semidet, in, in, in, mdi, muo) > + is semidet. > +:- mode do_foldr_pred(pred(in, di, uo) is semidet, in, in, in, di, uo) > + is semidet. > + > +do_foldr_pred(P, Min, I, A, !Acc) :- > + ( if I < Min then > + true > + else > + P(A ^ unsafe_elem(I), !Acc), > + do_foldr_pred(P, Min, I - 1, A, !Acc) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldr2(P, A, !Acc1, !Acc2) :- > + do_foldr2(P, array.min(A), array.max(A), A, !Acc1, !Acc2). > + > +:- pred do_foldr2(pred(T1, T2, T2, T3, T3), int, int, array(T1), T2, T2, > + T3, T3). > +:- mode do_foldr2(pred(in, in, out, in, out) is det, in, in, in, in, out, > + in, out) is det. > +:- mode do_foldr2(pred(in, in, out, mdi, muo) is det, in, in, in, in, out, > + mdi, muo) is det. > +:- mode do_foldr2(pred(in, in, out, di, uo) is det, in, in, in, in, out, > + di, uo) is det. > +:- mode do_foldr2(pred(in, in, out, in, out) is semidet, in, in, in, in, out, > + in, out) is semidet. > +:- mode do_foldr2(pred(in, in, out, mdi, muo) is semidet, in, in, in, in, out, > + mdi, muo) is semidet. > +:- mode do_foldr2(pred(in, in, out, di, uo) is semidet, in, in, in, in, out, > + di, uo) is semidet. > + > +do_foldr2(P, Min, I, A, !Acc1, !Acc2) :- > + ( if I < Min then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2), > + do_foldr2(P, Min, I - 1, A, !Acc1, !Acc2) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldr3(P, A, !Acc1, !Acc2, !Acc3) :- > + do_foldr3(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3). > + > +:- pred do_foldr3(pred(T1, T2, T2, T3, T3, T4, T4), int, int, array(T1), > + T2, T2, T3, T3, T4, T4). > +:- mode do_foldr3(pred(in, in, out, in, out, in, out) is det, in, in, in, > + in, out, in, out, in, out) is det. > +:- mode do_foldr3(pred(in, in, out, in, out, mdi, muo) is det, in, in, in, > + in, out, in, out, mdi, muo) is det. > +:- mode do_foldr3(pred(in, in, out, in, out, di, uo) is det, in, in, in, > + in, out, in, out, di, uo) is det. > +:- mode do_foldr3(pred(in, in, out, in, out, in, out) is semidet, in, in, in, > + in, out, in, out, in, out) is semidet. > +:- mode do_foldr3(pred(in, in, out, in, out, mdi, muo) is semidet, in, in, in, > + in, out, in, out, mdi, muo) is semidet. > +:- mode do_foldr3(pred(in, in, out, in, out, di, uo) is semidet, in, in, in, > + in, out, in, out, di, uo) is semidet. > + > +do_foldr3(P, Min, I, A, !Acc1, !Acc2, !Acc3) :- > + ( if I < Min then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3), > + do_foldr3(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldr4(P, A, !Acc1, !Acc2, !Acc3, !Acc4) :- > + do_foldr4(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4). > + > +:- pred do_foldr4(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5), int, int, > + array(T1), T2, T2, T3, T3, T4, T4, T5, T5). > +:- mode do_foldr4(pred(in, in, out, in, out, in, out, in, out) is det, in, in, > + in, in, out, in, out, in, out, in, out) is det. > +:- mode do_foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is det, in, in, > + in, in, out, in, out, in, out, mdi, muo) is det. > +:- mode do_foldr4(pred(in, in, out, in, out, in, out, di, uo) is det, in, in, > + in, in, out, in, out, in, out, di, uo) is det. > +:- mode do_foldr4(pred(in, in, out, in, out, in, out, in, out) is semidet, > + in, in, in, in, out, in, out, in, out, in, out) is semidet. > +:- mode do_foldr4(pred(in, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, in, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode do_foldr4(pred(in, in, out, in, out, in, out, di, uo) is semidet, > + in, in, in, in, out, in, out, in, out, di, uo) is semidet. > + > +do_foldr4(P, Min, I, A, !Acc1, !Acc2, !Acc3, !Acc4) :- > + ( if I < Min then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4), > + do_foldr4(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3, !Acc4) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldr5(P, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- > + do_foldr5(P, array.min(A), array.max(A), A, !Acc1, !Acc2, !Acc3, !Acc4, > + !Acc5). > + > +:- pred do_foldr5(pred(T1, T2, T2, T3, T3, T4, T4, T5, T5, T6, T6), > + int, int, array(T1), T2, T2, T3, T3, T4, T4, T5, T5, T6, T6). > +:- mode do_foldr5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is det, > + in, in, in, in, out, in, out, in, out, in, out, in, out) is det. > +:- mode do_foldr5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is det, > + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is det. > +:- mode do_foldr5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is det, > + in, in, in, in, out, in, out, in, out, in, out, di, uo) is det. > +:- mode do_foldr5( > + pred(in, in, out, in, out, in, out, in, out, in, out) is semidet, > + in, in, in, in, out, in, out, in, out, in, out, in, out) is semidet. > +:- mode do_foldr5( > + pred(in, in, out, in, out, in, out, in, out, mdi, muo) is semidet, > + in, in, in, in, out, in, out, in, out, in, out, mdi, muo) is semidet. > +:- mode do_foldr5( > + pred(in, in, out, in, out, in, out, in, out, di, uo) is semidet, > + in, in, in, in, out, in, out, in, out, in, out, di, uo) is semidet. > + > +do_foldr5(P, Min, I, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) :- > + ( if I < Min then > + true > + else > + P(A ^ unsafe_elem(I), !Acc1, !Acc2, !Acc3, !Acc4, !Acc5), > + do_foldr5(P, Min, I - 1, A, !Acc1, !Acc2, !Acc3, !Acc4, !Acc5) > + ). > + > +%---------------------------------------------------------------------------% > + > +foldl_corresponding(P, A, B, !Acc) :- > + MaxA = array.max(A), > + MaxB = array.max(B), > + ( if MaxA = MaxB then > + do_foldl_corresponding(P, 0, MaxA, A, B, !Acc) > + else > + unexpected($pred, "mismatched array sizes") > + ). > + > +:- pred do_foldl_corresponding(pred(T1, T2, T3, T3), int, int, > + array(T1), array(T2), T3, T3). > +:- mode do_foldl_corresponding(in(pred(in, in, in, out) is det), in, in, > + in, in, in, out) is det. > +:- mode do_foldl_corresponding(in(pred(in, in, mdi, muo) is det), in, in, > + in, in, mdi, muo) is det. > +:- mode do_foldl_corresponding(in(pred(in, in, di, uo) is det), in, in, > + in, in, di, uo) is det. > +:- mode do_foldl_corresponding(in(pred(in, in, in, out) is semidet), in, in, > + in, in, in, out) is semidet. > +:- mode do_foldl_corresponding(in(pred(in, in, mdi, muo) is semidet), in, in, > + in, in, mdi, muo) is semidet. > +:- mode do_foldl_corresponding(in(pred(in, in, di, uo) is semidet), in, in, > + in, in, di, uo) is semidet. > + > +do_foldl_corresponding(P, I, Max, A, B, !Acc) :- > + ( if Max < I then > + true > + else > + P(A ^ unsafe_elem(I), B ^ unsafe_elem(I), !Acc), > + do_foldl_corresponding(P, I + 1, Max, A, B, !Acc) > + ). > + > +foldl2_corresponding(P, A, B, !Acc1, !Acc2) :- > + MaxA = array.max(A), > + MaxB = array.max(B), > + ( if MaxA = MaxB then > + do_foldl2_corresponding(P, 0, MaxA, A, B, !Acc1, !Acc2) > + else > + unexpected($pred, "mismatched array sizes") > + ). > + > +:- pred do_foldl2_corresponding(pred(T1, T2, T3, T3, T4, T4), int, int, > + array(T1), array(T2), T3, T3, T4, T4). > +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, in, out) is det), > + in, in, in, in, in, out, in, out) is det. > +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is det), > + in, in, in, in, in, out, mdi, muo) is det. > +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, di, uo) is det), > + in, in, in, in, in, out, di, uo) is det. > +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, in, out) is semidet), > + in, in, in, in, in, out, in, out) is semidet. > +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, mdi, muo) is semidet), > + in, in, in, in, in, out, mdi, muo) is semidet. > +:- mode do_foldl2_corresponding(in(pred(in, in, in, out, di, uo) is semidet), > + in, in, in, in, in, out, di, uo) is semidet. > + > +do_foldl2_corresponding(P, I, Max, A, B, !Acc1, !Acc2) :- > + ( if Max < I then > + true > + else > + P(A ^ unsafe_elem(I), B ^ unsafe_elem(I), !Acc1, !Acc2), > + do_foldl2_corresponding(P, I + 1, Max, A, B, !Acc1, !Acc2) > + ). > + > +%---------------------------------------------------------------------------% > + > +map_foldl(P, A, B, !Acc) :- > + N = array.size(A), > + ( if N =< 0 then > + B = array.make_empty_array > + else > + array.unsafe_lookup(A, 0, X), > + P(X, Y, !Acc), > + B1 = unsafe_init(N, Y, 0), > + map_foldl_2(P, 1, A, B1, B, !Acc) > + ). > + > +:- pred map_foldl_2(pred(T1, T2, T3, T3), > + int, array(T1), array(T2), array(T2), T3, T3). > +:- mode map_foldl_2(in(pred(in, out, in, out) is det), > + in, in, array_di, array_uo, in, out) is det. > +:- mode map_foldl_2(in(pred(in, out, mdi, muo) is det), > + in, in, array_di, array_uo, mdi, muo) is det. > +:- mode map_foldl_2(in(pred(in, out, di, uo) is det), > + in, in, array_di, array_uo, di, uo) is det. > +:- mode map_foldl_2(in(pred(in, out, in, out) is semidet), > + in, in, array_di, array_uo, in, out) is semidet. > + > +map_foldl_2(P, I, A, !B, !Acc) :- > + ( if I < array.size(A) then > + array.unsafe_lookup(A, I, X), > + P(X, Y, !Acc), > + array.unsafe_set(I, Y, !B), > + map_foldl_2(P, I + 1, A, !B, !Acc) > + else > + true > + ). > + > +%---------------------------------------------------------------------------% > + > +map_corresponding_foldl(P, A, B, C, !Acc) :- > + SizeA = array.size(A), > + SizeB = array.size(B), > + ( if SizeA \= SizeB then > + unexpected($pred, "mismatched array sizes") > + else if SizeA =< 0 then > + C = array.make_empty_array > + else > + array.unsafe_lookup(A, 0, X), > + array.unsafe_lookup(B, 0, Y), > + P(X, Y, Z, !Acc), > + C1 = unsafe_init(SizeA, Z, 0), > + map_corresponding_foldl_2(P, 1, SizeA, A, B, C1, C, !Acc) > + ). > + > +:- pred map_corresponding_foldl_2(pred(T1, T2, T3, T4, T4), > + int, int, array(T1), array(T2), array(T3), array(T3), T4, T4). > +:- mode map_corresponding_foldl_2( > + in(pred(in, in, out, in, out) is det), > + in, in, in, in, array_di, array_uo, in, out) is det. > +:- mode map_corresponding_foldl_2( > + in(pred(in, in, out, mdi, muo) is det), > + in, in, in, in, array_di, array_uo, mdi, muo) is det. > +:- mode map_corresponding_foldl_2( > + in(pred(in, in, out, di, uo) is det), > + in, in, in, in, array_di, array_uo, di, uo) is det. > +:- mode map_corresponding_foldl_2( > + in(pred(in, in, out, in, out) is semidet), > + in, in, in, in, array_di, array_uo, in, out) is semidet. > +:- mode map_corresponding_foldl_2( > + in(pred(in, in, out, mdi, muo) is semidet), > + in, in, in, in, array_di, array_uo, mdi, muo) is semidet. > +:- mode map_corresponding_foldl_2( > + in(pred(in, in, out, di, uo) is semidet), > + in, in, in, in, array_di, array_uo, di, uo) is semidet. > + > +map_corresponding_foldl_2(P, I, N, A, B, !C, !Acc) :- > + ( if I < N then > + array.unsafe_lookup(A, I, X), > + array.unsafe_lookup(B, I, Y), > + P(X, Y, Z, !Acc), > + array.unsafe_set(I, Z, !C), > + map_corresponding_foldl_2(P, I + 1, N, A, B, !C, !Acc) > + else > + true > + ). > + > +%---------------------------------------------------------------------------% > + > +all_true(Pred, Array) :- > + do_all_true(Pred, array.min(Array), array.max(Array), Array). > + > +:- pred do_all_true(pred(T), int, int, array(T)). > +%:- mode do_all_true(in(pred(in) is semidet), in, in, array_ui) is semidet. > +:- mode do_all_true(in(pred(in) is semidet), in, in, in) is semidet. > + > +do_all_true(Pred, I, UB, Array) :- > + ( if I =< UB then > + array.unsafe_lookup(Array, I, Elem), > + Pred(Elem), > + do_all_true(Pred, I + 1, UB, Array) > + else > + true > + ). > + > +all_false(Pred, Array) :- > + do_all_false(Pred, array.min(Array), array.max(Array), Array). > + > +:- pred do_all_false(pred(T), int, int, array(T)). > +%:- mode do_all_false(in(pred(in) is semidet), in, in, array_ui) is semidet. > +:- mode do_all_false(in(pred(in) is semidet), in, in, in) is semidet. > + > +do_all_false(Pred, I, UB, Array) :- > + ( if I =< UB then > + array.unsafe_lookup(Array, I, Elem), > + not Pred(Elem), > + do_all_false(Pred, I + 1, UB, Array) > + else > + true > + ). > + > +%---------------------------------------------------------------------------% > +%---------------------------------------------------------------------------% > + > + % SAMsort (smooth applicative merge) invented by R.A. O'Keefe. > + % > + % SAMsort is a mergesort variant that works by identifying contiguous > + % monotonic sequences and merging them, thereby taking advantage of > + % any existing order in the input sequence. > + % > +:- func samsort_subarray(array(T)::array_di, int::in, int::in) = > + (array(T)::array_uo) is det. > + > +:- pragma type_spec(samsort_subarray/3, T = int). > +:- pragma type_spec(samsort_subarray/3, T = string). > + > +samsort_subarray(A0, Lo, Hi) = A :- > + samsort_up(0, array.copy(A0), A, A0, _, Lo, Hi, Lo). > + > + % samsort_up(N, A0, A, B0, B, Lo, Hi, I): > + % > + % Precondition: > + % We are N levels from the bottom (leaf nodes) of the tree. > + % A0 is sorted from Lo .. I - 1. > + % A0 and B0 are identical from I .. Hi. > + % Postcondition: > + % A is sorted from Lo .. Hi. > + % > +:- pred samsort_up(int::in, array(T)::array_di, array(T)::array_uo, > + array(T)::array_di, array(T)::array_uo, int::in, int::in, int::in) is det. > + > +:- pragma type_spec(samsort_up/8, T = int). > +:- pragma type_spec(samsort_up/8, T = string). > + > +samsort_up(N, A0, A, B0, B, Lo, Hi, I) :- > + trace [compile_time(flag("array_sort"))] ( > + verify_sorted(A0, Lo, I - 1), > + verify_identical(A0, B0, I, Hi) > + ), > + ( if I > Hi then > + A = A0, > + B = B0 > + % A is sorted from Lo .. Hi. > + else if N > 0 then > + % B0 and A0 are identical from I .. Hi. > + samsort_down(N - 1, B0, B1, A0, A1, I, Hi, J), > + % A1 is sorted from I .. J - 1. > + % B1 and A1 are identical from J .. Hi. > + > + merge_subarrays(A1, Lo, I - 1, I, J - 1, Lo, B1, B2), > + A2 = A1, > + > + % B2 is sorted from Lo .. J - 1. > + % B2 and A2 are identical from J .. Hi. > + samsort_up(N + 1, B2, B3, A2, A3, Lo, Hi, J), > + % B3 is sorted from Lo .. Hi. > + > + A = B3, > + B = A3 > + % A is sorted from Lo .. Hi. > + else > + % N = 0, I = Lo > + copy_run_ascending(A0, B0, B1, Lo, Hi, J), > + > + % B1 is sorted from Lo .. J - 1. > + % B1 and A0 are identical from J .. Hi. > + samsort_up(N + 1, B1, B2, A0, A2, Lo, Hi, J), > + % B2 is sorted from Lo .. Hi. > + > + A = B2, > + B = A2 > + % A is sorted from Lo .. Hi. > + ), > + trace [compile_time(flag("array_sort"))] ( > + verify_sorted(A, Lo, Hi) > + ). > + > + % samsort_down(N, A0, A, B0, B, Lo, Hi, I): > + % > + % Precondition: > + % We are N levels from the bottom (leaf nodes) of the tree. > + % A0 and B0 are identical from Lo .. Hi. > + % Postcondition: > + % B is sorted from Lo .. I - 1. > + % A and B are identical from I .. Hi. > + % > +:- pred samsort_down(int::in, array(T)::array_di, array(T)::array_uo, > + array(T)::array_di, array(T)::array_uo, int::in, int::in, int::out) is det. > + > +:- pragma type_spec(samsort_down/8, T = int). > +:- pragma type_spec(samsort_down/8, T = string). > + > +samsort_down(N, A0, A, B0, B, Lo, Hi, I) :- > + trace [compile_time(flag("array_sort"))] ( > + verify_identical(A0, B0, Lo, Hi) > + ), > + ( if Lo > Hi then > + A = A0, > + B = B0, > + I = Lo > + % B is sorted from Lo .. I - 1. > + else if N > 0 then > + samsort_down(N - 1, B0, B1, A0, A1, Lo, Hi, J), > + samsort_down(N - 1, B1, B2, A1, A2, J, Hi, I), > + % A2 is sorted from Lo .. J - 1. > + % A2 is sorted from J .. I - 1. > + A = A2, > + merge_subarrays(A2, Lo, J - 1, J, I - 1, Lo, B2, B) > + % B is sorted from Lo .. I - 1. > + else > + A = A0, > + copy_run_ascending(A0, B0, B, Lo, Hi, I) > + % B is sorted from Lo .. I - 1. > + ), > + trace [compile_time(flag("array_sort"))] ( > + verify_sorted(B, Lo, I - 1), > + verify_identical(A, B, I, Hi) > + ). > + > +:- pred verify_sorted(array(T)::array_ui, int::in, int::in) is det. > + > +verify_sorted(A, Lo, Hi) :- > + ( if Lo >= Hi then > + true > + else if compare((<), A ^ elem(Lo + 1), A ^ elem(Lo)) then > + unexpected($pred, "array range not sorted") > + else > + verify_sorted(A, Lo + 1, Hi) > + ). > + > +:- pred verify_identical(array(T)::array_ui, array(T)::array_ui, > + int::in, int::in) is det. > + > +verify_identical(A, B, Lo, Hi) :- > + ( if Lo > Hi then > + true > + else if A ^ elem(Lo) = B ^ elem(Lo) then > + verify_identical(A, B, Lo + 1, Hi) > + else > + unexpected($pred, "array ranges not identical") > + ). > + > +%---------------------------------------------------------------------------% > + > +:- pred copy_run_ascending(array(T)::array_ui, > + array(T)::array_di, array(T)::array_uo, int::in, int::in, int::out) is det. > + > +:- pragma type_spec(copy_run_ascending/6, T = int). > +:- pragma type_spec(copy_run_ascending/6, T = string). > + > +copy_run_ascending(A, !B, Lo, Hi, I) :- > + ( if > + Lo < Hi, > + compare((>), A ^ elem(Lo), A ^ elem(Lo + 1)) > + then > + I = search_until((<), A, Lo, Hi), > + copy_subarray_reverse(A, Lo, I - 1, I - 1, !B) > + else > + I = search_until((>), A, Lo, Hi), > + copy_subarray(A, Lo, I - 1, Lo, !B) > + ). > + > +%---------------------------------------------------------------------------% > + > +:- func search_until(comparison_result::in, array(T)::array_ui, > + int::in, int::in) = (int::out) is det. > + > +:- pragma type_spec(search_until/4, T = int). > +:- pragma type_spec(search_until/4, T = string). > + > +search_until(R, A, Lo, Hi) = > + ( if > + Lo < Hi, > + not compare(R, A ^ elem(Lo), A ^ elem(Lo + 1)) > + then > + search_until(R, A, Lo + 1, Hi) > + else > + Lo + 1 > + ). > + > +%---------------------------------------------------------------------------% > + > + % Assigns the subarray A[Lo..Hi] to B[InitI..Final], where InitI > + % is the initial value of I, and FinalI = InitI + (Ho - Lo + 1). > + % In this version, I is ascending, so B[InitI] gets A[Lo] > + % > +:- pred copy_subarray(array(T)::array_ui, int::in, int::in, int::in, > + array(T)::array_di, array(T)::array_uo) is det. > + > +:- pragma type_spec(copy_subarray/6, T = int). > +:- pragma type_spec(copy_subarray/6, T = string). > + > +copy_subarray(A, Lo, Hi, I, !B) :- > + ( if Lo =< Hi then > + array.lookup(A, Lo, X), > + % XXX Would it be safe to replace this with array.unsafe_set? > + array.set(I, X, !B), > + copy_subarray(A, Lo + 1, Hi, I + 1, !B) > + else > + true > + ). > + > + % Assigns the subarray A[Lo..Hi] to B[InitI..Final], where InitI > + % is the initial value of I, and FinalI = InitI - (Ho - Lo + 1). > + % In this version, I is descending, so B[InitI] gets A[Hi]. > + % > +:- pred copy_subarray_reverse(array(T)::array_ui, int::in, int::in, int::in, > + array(T)::array_di, array(T)::array_uo) is det. > + > +:- pragma type_spec(copy_subarray_reverse/6, T = int). > +:- pragma type_spec(copy_subarray_reverse/6, T = string). > + > +copy_subarray_reverse(A, Lo, Hi, I, !B) :- > + ( if Lo =< Hi then > + array.lookup(A, Lo, X), > + % XXX Would it be safe to replace this with array.unsafe_set? > + array.set(I, X, !B), > + copy_subarray_reverse(A, Lo + 1, Hi, I - 1, !B) > + else > + true > + ). > + > +%---------------------------------------------------------------------------% > + > + % merges the two sorted consecutive subarrays Lo1 .. Hi1 and Lo2 .. Hi2 > + % from A into the subarray starting at I in B. > + % > +:- pred merge_subarrays(array(T)::array_ui, > + int::in, int::in, int::in, int::in, int::in, > + array(T)::array_di, array(T)::array_uo) is det. > + > +:- pragma type_spec(merge_subarrays/8, T = int). > +:- pragma type_spec(merge_subarrays/8, T = string). > + > +merge_subarrays(A, Lo1, Hi1, Lo2, Hi2, I, !B) :- > + ( if Lo1 > Hi1 then > + copy_subarray(A, Lo2, Hi2, I, !B) > + else if Lo2 > Hi2 then > + copy_subarray(A, Lo1, Hi1, I, !B) > + else > + array.lookup(A, Lo1, X1), > + array.lookup(A, Lo2, X2), > + compare(R, X1, X2), > + ( > + R = (<), > + array.set(I, X1, !B), > + merge_subarrays(A, Lo1 + 1, Hi1, Lo2, Hi2, I + 1, !B) > + ; > + R = (=), > + array.set(I, X1, !B), > + merge_subarrays(A, Lo1 + 1, Hi1, Lo2, Hi2, I + 1, !B) > + ; > + R = (>), > + array.set(I, X2, !B), > + merge_subarrays(A, Lo1, Hi1, Lo2 + 1, Hi2, I + 1, !B) > + ) > + ). > + > +%---------------------------------------------------------------------------% > + > + % Throw an exception indicating an array bounds error. > + % > +:- pred out_of_bounds_error(array(T), int, string). > +%:- mode out_of_bounds_error(array_ui, in, in) is erroneous. > +:- mode out_of_bounds_error(in, in, in) is erroneous. > + > +out_of_bounds_error(Array, Index, PredName) :- > + % Note: we deliberately do not include the array element type name in the > + % error message here, for performance reasons: using the type name could > + % prevent the compiler from optimizing away the construction of the > + % type_info in the caller, because it would prevent unused argument > + % elimination. Performance is important here, because array.set and > + % array.lookup are likely to be used in the inner loops of > + % performance-critical applications. > + array.bounds(Array, Min, Max), > + string.format("%s: index %d not in range [%d, %d]", > + [s(PredName), i(Index), i(Min), i(Max)], Msg), > + throw(array.index_out_of_bounds(Msg)). > + > + % Like the above, but for use in cases where the are multiple arguments > + % that correspond to array indices. > + % > +:- pred arg_out_of_bounds_error(array(T), string, string, int). > +:- mode arg_out_of_bounds_error(in, in, in, in) is erroneous. > + > +arg_out_of_bounds_error(Array, ArgPosn, PredName, Index) :- > + array.bounds(Array, Min, Max), > + string.format("%s argument of %s: index %d not in range [%d, %d]", > + [s(ArgPosn), s(PredName), i(Index), i(Min), i(Max)], Msg), > + throw(array.index_out_of_bounds(Msg)). > + > +%---------------------------------------------------------------------------% > + > +det_least_index(A) = Index :- > + ( if array.is_empty(A) then > + unexpected($pred, "empty array") > + else > + Index = array.min(A) > + ). > + > +semidet_least_index(A) = Index :- > + ( if array.is_empty(A) then > + fail > + else > + Index = array.min(A) > + ). > + > +%---------------------------------------------------------------------------% > + > +det_greatest_index(A) = Index :- > + ( if array.is_empty(A) then > + unexpected($pred, "empty array") > + else > + Index = array.max(A) > + ). > + > +semidet_greatest_index(A) = Index :- > + ( if array.is_empty(A) then > + fail > + else > + Index = array.max(A) > + ). > + > +%---------------------------------------------------------------------------% > + > +array_to_doc(A) = > + indent([str("array(["), array_to_doc_2(0, A), str("])")]). > + > +:- func array_to_doc_2(int, array(T)) = doc. > + > +array_to_doc_2(I, A) = > + ( if I > array.max(A) then > + str("") > + else > + docs([ > + format_arg(format(A ^ elem(I))), > + ( if I = array.max(A) then str("") else group([str(", "), nl]) ), > + format_susp((func) = array_to_doc_2(I + 1, A)) > + ]) > + ). > + > +%---------------------------------------------------------------------------% > + > +dynamic_cast_to_array(X, A) :- > + % If X is an array then it has a type with one type argument. > + [ArgTypeDesc] = type_args(type_of(X)), > + > + % Convert ArgTypeDesc to a type variable ArgType. > + (_ `with_type` ArgType) `has_type` ArgTypeDesc, > + > + % Constrain the type of A to be array(ArgType) and do the cast. > + dynamic_cast(X, A `with_type` array(ArgType)). > + > +%---------------------------------------------------------------------------% > +:- end_module array. > +%---------------------------------------------------------------------------% > -- > 2.26.3 > > ^ permalink raw reply [flat|nested] 27+ messages in thread
[parent not found: <53162dfb-0715-3077-78d1-3a8340943f2f@gmail.com>]
* bug#47408: Fwd: bug#47408: Etags support for Mercury [v0.4] [not found] ` <53162dfb-0715-3077-78d1-3a8340943f2f@gmail.com> @ 2021-05-29 8:01 ` Eli Zaretskii [not found] ` <CANTSrJtDMu=4SWUcBRt51X8n42mOfB6_sFi8mNoZ0YgYdtE-DA@mail.gmail.com> 2021-06-01 2:38 ` bug#47408: Etags support for Mercury [v0.5] fabrice nicol 0 siblings, 2 replies; 27+ messages in thread From: Eli Zaretskii @ 2021-05-29 8:01 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 [Please use Reply All to have the bug address on the CC list.] > From: fabrice nicol <fabrnicol@gmail.com> > Date: Sat, 15 May 2021 12:19:26 +0200 > > The confusion stems from an earlier discussion with a third party (I > forgot his name), who proposed to reuse '--no-defines' **and** > '--declarations' to replace Mercury-specific short options that I had > introduced. You followed this advice and so did I except for one detail > that I will outline below. > > To make things clearer, I will rephrase the way I implemented this: > > 1. There are **no longer** Mercury-specific short options -m/-M. > > 2. As advised by this third party and your review comments, > '--declarations' is implemented in a Mercury-specific way (hence the - > correct - NEWS item about it, as well as a couple of sentences in the > man page, this is just what your review advised). > > Using '--declarations', etags will tag not only Mercury language > declarations (strictly speaking) but also 'legacy declarations', i.e. > the old Prolog way (in actual terms, these are definitions in Mercury, > but there is unfortunately no '--definitions' etags options, so we must > do with what we have in store). OK. But the documentation patches you submitted seem to be somewhat confusing: will Mercury declarations be tagged by default, or only when --declarations is used? This option isn't the default in etags, so either the declarations are tagged by default (i.e. without using this option) or only when --declarations is specified on the command line. You seem to say both, which I don't understand. And I have several minor comments to the patch: > +In Mercury, declarations start a line with "\|\fB:-\fP\|" and are tagged > +by default. Here, this is the confusing part about tagging Mercury declarations. > ++++ > +** 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'. And this as well. It leaves me wondering what is the difference between the results when using --declarations and not using it. > --- /dev/null > +++ b/lib-src/ChangeLog We don't maintain ChangeLog files anymore in the repository, so what you wanted to say there should be instead in the commit log message (which you didn't include). See CONTRIBUTE for more details about formatting commit log messages. > + /* Disambiguate file names between Objc and Mercury */ > + if (lang != NULL && strcmp(lang->name, "objc") == 0) > + test_objc_is_mercury(curfdp->infname, &lang); Our C style conventions are to leave one space between the function's name and the left parenthesis following it, as below: if (lang != NULL && strcmp (lang->name, "objc") == 0) test_objc_is_mercury (curfdp->infname, &lang); Please make sure you use this style everywhere. > 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. Adding test file(s) for Mercury is great, but we cannot have there files under arbitrary license/copyright. If COPYING.LIB mentioned above specifies GPL or a compatible license, then it's okay for us to distribute this file, but we need a copy of that COPYING.LIB file as well. If the license is not compatible with GPL, we cannot distribute this file; in that case, please find some other test file, or provide your own. Thanks. ^ permalink raw reply [flat|nested] 27+ messages in thread
[parent not found: <CANTSrJtDMu=4SWUcBRt51X8n42mOfB6_sFi8mNoZ0YgYdtE-DA@mail.gmail.com>]
* bug#47408: Fwd: bug#47408: Etags support for Mercury [v0.4] [not found] ` <CANTSrJtDMu=4SWUcBRt51X8n42mOfB6_sFi8mNoZ0YgYdtE-DA@mail.gmail.com> @ 2021-05-29 10:22 ` Eli Zaretskii 0 siblings, 0 replies; 27+ messages in thread From: Eli Zaretskii @ 2021-05-29 10:22 UTC (permalink / raw) To: Fabrice Nicol; +Cc: 47408 [Once again, please use Reply All, to keep the bug address on the CC list.] > From: Fabrice Nicol <fabrnicol@gmail.com> > Date: Sat, 29 May 2021 12:06:57 +0200 > > Hi Eli, > All your comments are fine by me and I will make the requested adjustments within a week. Thanks. > FYI, Mercury is entirely GPL, so there should be no licensing issue. It is just the authors' status that changed > (from a university team to a private team), but this does not impact the licensing terms. I will document this. I'm not talking about the license of Mercury, I'm talking about the license of the file you added to the etags test suite. We must have clear understanding and documentation about its legal status. P.S. Please be sure to CC the bug address on your future messages in this matter. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-05-29 8:01 ` Eli Zaretskii [not found] ` <CANTSrJtDMu=4SWUcBRt51X8n42mOfB6_sFi8mNoZ0YgYdtE-DA@mail.gmail.com> @ 2021-06-01 2:38 ` fabrice nicol 2021-06-06 9:48 ` Eli Zaretskii 1 sibling, 1 reply; 27+ messages in thread From: fabrice nicol @ 2021-06-01 2:38 UTC (permalink / raw) To: Eli Zaretskii; +Cc: 47408 [-- Attachment #1: Type: text/plain, Size: 6136 bytes --] Hi Eli, >> Using '--declarations', etags will tag not only Mercury language >> declarations (strictly speaking) but also 'legacy declarations', i.e. >> the old Prolog way (in actual terms, these are definitions in Mercury, >> but there is unfortunately no '--definitions' etags options, so we must >> do with what we have in store). > OK. But the documentation patches you submitted seem to be somewhat > confusing: will Mercury declarations be tagged by default, or only > when --declarations is used? Mercury-specific declarations will be tagged by default. What is confusing is not the implementation but the fact that, after it was decided **not** to use language-specific options (like the initially proposed -m/-M), we were left with no choice as to which existing option could be used to implement the optional "Prolog legacy/porting" behavior. --declarations was the option that the first third-party reviewer proposed, and both of us followed suit. It is to be understood as "**all** declarations", meaning Mercury-specific declarations **and** Prolog-support-style declarations (i.e. first rule predicates in clauses). I've tried to make the documentation patch a bit clearer. > This option isn't the default in etags, > so either the declarations are tagged by default (i.e. without using > this option) Yes. Mercury-specific declarations are tagged by default, this is what I explained in my latest two emails. > or only when --declarations is specified on the command > line. No. --declarations adds Prolog-style 'declarations' in addition to Mercury-specific declarations, so that porting Prolog to Mercury is facilitated. It is always necessary to tag Mercury-specific (non-Prolog-style) declarations, in all circumstances. It is only useful to tag Prolog-style declarations (actually definitions) in some circumstances. > You seem to say both, which I don't understand. Mercury-specific declarations are tagged by default **and** with --declarations. This is what the Mercury community wants, I consulted them on the user list. Prolog-style 'declarations' (which are actually definitions, as there are **no** declarations in Prolog) are additionaly tagged when --declarations is used. > And I have several minor comments to the patch: > >> +In Mercury, declarations start a line with "\|\fB:-\fP\|" and are tagged >> +by default. >> >> Here, this is the confusing part about tagging Mercury declarations. This will not be confusing to people who have practiced Mercury even a little bit. A Mercury-specific declaration is by definition preceded by ':-'. I changed this to '... and are always tagged'. Which may be clearer. >> ++++ >> +** 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'. >> >> And this as well. It leaves me wondering what is the difference >> between the results when using --declarations and not using it. By default, when --declarations is not used, all Mercury-specific declarations (i.e. beginning a line with ':-' ) are tagged, **and only them**. When --declarations is used, all Mercury-specific declarations **plus** all Prolog-support-style 'declarations' are tagged. I see no confusing phrasing in the proposed sentences. I changed 'also' into 'in addition', which is (perhaps) clearer. >> --- /dev/null >> +++ b/lib-src/ChangeLog > We don't maintain ChangeLog files anymore in the repository, so what > you wanted to say there should be instead in the commit log message > (which you didn't include). See CONTRIBUTE for more details about > formatting commit log messages. Ah, I thought commit log messages were yours to make as I am not granted committing rights. >> + /* Disambiguate file names between Objc and Mercury */ >> + if (lang != NULL && strcmp(lang->name, "objc") == 0) >> + test_objc_is_mercury(curfdp->infname, &lang); > Our C style conventions are to leave one space between the function's > name and the left parenthesis following it, as below: > > if (lang != NULL && strcmp (lang->name, "objc") == 0) > test_objc_is_mercury (curfdp->infname, &lang); > > Please make sure you use this style everywhere. Done. >> 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. > Adding test file(s) for Mercury is great, but we cannot have there > files under arbitrary license/copyright. If COPYING.LIB mentioned > above specifies GPL or a compatible license, then it's okay for us to > distribute this file, but we need a copy of that COPYING.LIB file as > well. If the license is not compatible with GPL, we cannot distribute > this file; in that case, please find some other test file, or provide > your own. > > Thanks. OK. Upon closer inspection, the COPYING.LIB license that applies to library files is a kind of dual license with an optional way out of GPL v2 into LGPL-like licensing terms. Admittedly this is a bit complex and uncertain. However these complex licensing terms only apply to library files. Compiler files, on the contrary, are casher GPLv2. So I removed my example file (array.m from the library) and replaced it with a compiler file (accumulator.m). This now leaves no uncertainty whatsoever. The COPYING file referred to in the accumulator.m header is GPL v2. I hope this works, Fabrice [-- Attachment #2: 0001-Add-etags-support-for-Mercury-[v0.5].patch --] [-- Type: text/x-patch, Size: 104557 bytes --] From f52a7dee78949190aafe716d01654ee647f3dc61 Mon Sep 17 00:00:00 2001 From: Fabrice Nicol <fabrnicol@gmail.com> Date: Tue, 1 Jun 2021 04:15:59 +0200 Subject: [PATCH] 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. --- doc/man/etags.1 | 23 +- etc/NEWS | 7 + lib-src/etags.c | 490 +++++- test/manual/etags/Makefile | 3 +- test/manual/etags/merc-src/accumulator.m | 1954 ++++++++++++++++++++++ 5 files changed, 2464 insertions(+), 13 deletions(-) create mode 100644 test/manual/etags/merc-src/accumulator.m diff --git a/doc/man/etags.1 b/doc/man/etags.1 index 354f6ca88b..cbd3c1a646 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, Rust, PHP, PostScript, Python, Prolog, Scheme and -most assembler\-like syntaxes. +Forth, Go, HTML, LaTeX, Emacs Lisp/Common Lisp, Lua, Makefile, Mercury, Pascal, +Perl, Ruby, Rust, 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 always +tagged. In addition, this option 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 6622861aaf..c9c5c97719 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -111,6 +111,13 @@ filters. \f * Changes in Emacs 28.1 ++++ +** Etags support for the Mercury programming language (https://mercurylang.org). +** Etags command line option --declarations now has Mercury-specific behavior. +All Mercury declarations are tagged by default. +For compatibility with Prolog etags support, predicates and functions appearing +first in clauses will also be tagged if etags is run with '--declarations'. + +++ ** New command 'font-lock-update', bound to 'C-x x f'. This command updates the syntax highlighting in this buffer. diff --git a/lib-src/etags.c b/lib-src/etags.c index d703183cef..ac1fbb4df5 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 *); @@ -379,6 +387,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); @@ -684,10 +693,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\ @@ -831,7 +852,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 }, @@ -958,6 +981,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."); @@ -1783,6 +1809,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; @@ -6070,6 +6101,457 @@ prolog_atom (char *s, size_t pos) return 0; } +\f +/* + * Support for Mercury + * + * Assumes that the declarationa starts at column 0. + * Original code by Sunichirou Sugou (1989) for Prolog. + * Rewritten by Anders Lindgren (1996) for Prolog. + * Adapted by Fabrice Nicol (2021) for Mercury. + * Note: Prolog-support behavior is preserved if + * --declarations is used, corresponding to + * with_mercury_definitions=true. + */ + +static ptrdiff_t mercury_pr (char *, char *, ptrdiff_t); +static void mercury_skip_comment (linebuffer *, FILE *); +static bool is_mercury_type = false; +static bool is_mercury_quantifier = false; +static bool is_mercury_declaration = false; + +/* + * Objective-C and Mercury have identical file extension .m + * To disambiguate between Objective C and Mercury, parse file + * with the following heuristics hook: + * - if line starts with :- choose Mercury unconditionally, + * - if line starts with #, @, choose Objective-C, + * - otherwise compute the following ratio: + * + * r = (number of lines with :- + * or % in non-commented parts or . at trimmed EOL) + * / (number of lines - number of lines starting by any amount + * of whitespace, optionally followed by comment(s)) + * + * Note: strings are neglected in counts. + * + * If r > mercury_heuristics_ratio, choose Mercury. + * Experimental tests show that a possibly optimal default value for + * this floor value is around 0.5. This is the default value for + * MERCURY_HEURISTICS_RATIO, defined in the first lines of this file. + * The closer r to 0.5, the closer the source code to pure Prolog. + * Idiomatic Mercury is scored either with r = 1.0 or higher. + * Objective-C is scored with r = 0.0. When this fails, the r-score never + * rose above 0.1 in Objective-C tests. + */ + +static void +test_objc_is_mercury (char *this_file, language **lang) +{ + if (this_file == NULL) return; + FILE* fp = fopen (this_file, "r"); + if (fp == NULL) + pfatal (this_file); + + bool blank_line = false; /* Line starting with any amount of white space + followed by optional comment(s). */ + bool commented_line = false; + bool found_dot = false; + bool only_space_before = true; + bool start_of_line = true; + int c; + intmax_t lines = 1; + intmax_t mercury_dots = 0; + intmax_t percentage_signs = 0; + intmax_t rule_signs = 0; + float ratio = 0; + + while ((c = fgetc (fp)) != EOF) + { + switch (c) + { + case '\n': + if (! blank_line) ++lines; + blank_line = true; + commented_line = false; + start_of_line = true; + if (found_dot) ++mercury_dots; + found_dot = false; + only_space_before = true; + break; + case '.': + found_dot = ! commented_line; + only_space_before = false; + break; + case '%': /* More frequent in Mercury. May be modulo in Obj.-C. */ + if (! commented_line) + { + ++percentage_signs; + /* Cannot tell if it is a comment or modulo yet for sure. + Yet works for heuristic purposes. */ + commented_line = true; + } + found_dot = false; + start_of_line = false; + only_space_before = false; + break; + case '/': + { + int d = fgetc (fp); + found_dot = false; + only_space_before = false; + if (! commented_line) + { + if (d == '*') + commented_line = true; + else + /* If d == '/', cannot tell if it is an Obj.-C comment: + may be Mercury integ. division. */ + blank_line = false; + } + } + FALLTHROUGH; + case ' ': + case '\t': + start_of_line = false; + break; + case ':': + c = fgetc (fp); + if (start_of_line) + { + if (c == '-') + { + ratio = 1.0; /* Failsafe, not an operator in Obj.-C. */ + goto out; + } + start_of_line = false; + } + else + { + /* p :- q. Frequent in Mercury. + Rare or in quoted exprs in Obj.-C. */ + if (c == '-' && ! commented_line) + ++rule_signs; + } + blank_line = false; + found_dot = false; + only_space_before = false; + break; + case '@': + case '#': + if (start_of_line || only_space_before) + { + ratio = 0.0; + goto out; + } + FALLTHROUGH; + default: + start_of_line = false; + blank_line = false; + found_dot = false; + only_space_before = false; + } + } + + /* Fallback heuristic test. Not failsafe but errless in pratice. */ + ratio = ((float) rule_signs + percentage_signs + mercury_dots) / lines; + + out: + if (fclose (fp) == EOF) + pfatal (this_file); + + if (ratio > mercury_heuristics_ratio) + { + /* Change the language from Objective C to Mercury. */ + static language lang0 = { "mercury", Mercury_help, Mercury_functions, + Mercury_suffixes }; + *lang = &lang0; + } +} + +static void +Mercury_functions (FILE *inf) +{ + char *cp, *last = NULL; + ptrdiff_t lastlen = 0, allocated = 0; + if (declarations) with_mercury_definitions = true; + + LOOP_ON_INPUT_LINES (inf, lb, cp) + { + if (cp[0] == '\0') /* Empty line. */ + continue; + else if (c_isspace (cp[0]) || cp[0] == '%') + /* A Prolog-type comment or anything other than a declaration. */ + continue; + else if (cp[0] == '/' && cp[1] == '*') /* Mercury C-type comment. */ + mercury_skip_comment (&lb, inf); + else + { + is_mercury_declaration = (cp[0] == ':' && cp[1] == '-'); + + if (is_mercury_declaration + || with_mercury_definitions) + { + ptrdiff_t len = mercury_pr (cp, last, lastlen); + if (0 < len) + { + /* Store the declaration to avoid generating duplicate + tags later. */ + if (allocated <= len) + { + xrnew (last, len + 1, 1); + allocated = len + 1; + } + memcpyz (last, cp, len); + lastlen = len; + } + } + } + } + free (last); +} + +static void +mercury_skip_comment (linebuffer *plb, FILE *inf) +{ + char *cp; + + do + { + for (cp = plb->buffer; *cp != '\0'; ++cp) + if (cp[0] == '*' && cp[1] == '/') + return; + readline (plb, inf); + } + while (perhaps_more_input (inf)); +} + +/* + * A declaration is added if it matches: + * <beginning of line>:-<whitespace><Mercury Term><whitespace>( + * If with_mercury_definitions == true, we also add: + * <beginning of line><Mercury item><whitespace>( + * or <beginning of line><Mercury item><whitespace>:- + * As for Prolog support, different arities and types are not taken into + * consideration. + * Item is added to the tags database if it doesn't match the + * name of the previous declaration. + * + * Consume a Mercury declaration. + * Return the number of bytes consumed, or 0 if there was an error. + * + * A Mercury declaration must be one of: + * :- type + * :- solver type + * :- pred + * :- func + * :- inst + * :- mode + * :- typeclass + * :- instance + * :- pragma + * :- promise + * :- initialise + * :- finalise + * :- mutable + * :- module + * :- interface + * :- implementation + * :- import_module + * :- use_module + * :- include_module + * :- end_module + * followed on the same line by an alphanumeric sequence, starting with a lower + * case letter or by a single-quoted arbitrary string. + * Single quotes can escape themselves. Backslash quotes everything. + * + * Return the size of the name of the declaration or 0 if no header was found. + * As quantifiers may precede functions or predicates, we must list them too. + */ + +static const char *Mercury_decl_tags[] = {"type", "solver type", "pred", + "func", "inst", "mode", "typeclass", "instance", "pragma", "promise", + "initialise", "finalise", "mutable", "module", "interface", "implementation", + "import_module", "use_module", "include_module", "end_module", "some", "all"}; + +static size_t +mercury_decl (char *s, size_t pos) +{ + if (s == NULL) return 0; + + size_t origpos; + origpos = pos; + + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) ++pos; + + unsigned char decl_type_length = pos - origpos; + char buf[decl_type_length + 1]; + memset (buf, 0, decl_type_length + 1); + + /* Mercury declaration tags. Consume them, then check the declaration item + following :- is legitimate, then go on as in the prolog case. */ + + memcpy (buf, &s[origpos], decl_type_length); + + bool found_decl_tag = false; + + if (is_mercury_quantifier) + { + if (strcmp (buf, "pred") != 0 && strcmp (buf, "func") != 0) /* Bad syntax. */ + return 0; + is_mercury_quantifier = false; /* Beset to base value. */ + found_decl_tag = true; + } + else + { + for (int j = 0; j < sizeof (Mercury_decl_tags) / sizeof (char*); ++j) + { + if (strcmp (buf, Mercury_decl_tags[j]) == 0) + { + found_decl_tag = true; + if (strcmp (buf, "type") == 0) + is_mercury_type = true; + + if (strcmp (buf, "some") == 0 + || strcmp (buf, "all") == 0) + { + is_mercury_quantifier = true; + } + + break; /* Found declaration tag of rank j. */ + } + else + /* 'solver type' has a blank in the middle, + so this is the hard case. */ + if (strcmp (buf, "solver") == 0) + { + ++pos; + while (s + pos != NULL && (c_isalnum (s[pos]) || s[pos] == '_')) + ++pos; + + decl_type_length = pos - origpos; + char buf2[decl_type_length + 1]; + memset (buf2, 0, decl_type_length + 1); + memcpy (buf2, &s[origpos], decl_type_length); + + if (strcmp (buf2, "solver type") == 0) + { + found_decl_tag = false; + break; /* Found declaration tag of rank j. */ + } + } + } + } + + /* If with_mercury_definitions == false + * this is a Mercury syntax error, ignoring... */ + + if (with_mercury_definitions) + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */ + else + /* Prolog-like behavior + * we have parsed the predicate once, yet inappropriately + * so restarting again the parsing step. */ + pos = 0; + } + else + { + if (found_decl_tag) + pos = skip_spaces (s + pos) - s; /* Skip len blanks again. */ + else + return 0; + } + + /* From now on it is the same as for Prolog except for module dots. */ + + if (c_islower (s[pos]) || s[pos] == '_' ) + { + /* The name is unquoted. + Do not confuse module dots with end-of-declaration dots. */ + + while (c_isalnum (s[pos]) + || s[pos] == '_' + || (s[pos] == '.' /* A module dot. */ + && s + pos + 1 != NULL + && (c_isalnum (s[pos + 1]) || s[pos + 1] == '_'))) + ++pos; + + return pos - origpos; + } + else if (s[pos] == '\'') + { + ++pos; + for (;;) + { + if (s[pos] == '\'') + { + ++pos; + if (s[pos] != '\'') + break; + ++pos; /* A double quote. */ + } + else if (s[pos] == '\0') /* Multiline quoted atoms are ignored. */ + return 0; + else if (s[pos] == '\\') + { + if (s[pos+1] == '\0') + return 0; + pos += 2; + } + else + ++pos; + } + return pos - origpos; + } + else if (is_mercury_quantifier && s[pos] == '[') /* :- some [T] pred/func. */ + { + for (++pos; s + pos != NULL && s[pos] != ']'; ++pos) {} + if (s + pos == NULL) return 0; + ++pos; + pos = skip_spaces (s + pos) - s; + return mercury_decl (s, pos) + pos - origpos; + } + else + return 0; +} + +static ptrdiff_t +mercury_pr (char *s, char *last, ptrdiff_t lastlen) +{ + size_t len0 = 0; + is_mercury_type = false; + is_mercury_quantifier = false; + + if (is_mercury_declaration) + { + /* Skip len0 blanks only for declarations. */ + len0 = skip_spaces (s + 2) - s; + } + + size_t len = mercury_decl (s , len0); + if (len == 0) return 0; + len += len0; + + if (( (s[len] == '.' /* This is a statement dot, not a module dot. */ + || (s[len] == '(' && (len += 1)) + || (s[len] == ':' /* Stopping in case of a rule. */ + && s[len + 1] == '-' + && (len += 2))) + && (lastlen != len || memcmp (s, last, len) != 0) + ) + /* Types are often declared on several lines so keeping just + the first line. */ + || is_mercury_type) + { + make_tag (s, 0, true, s, len, lineno, linecharno); + return len; + } + + return 0; +} + \f /* * Support for Erlang diff --git a/test/manual/etags/Makefile b/test/manual/etags/Makefile index 8d56db29b7..b3a82fdba8 100644 --- a/test/manual/etags/Makefile +++ b/test/manual/etags/Makefile @@ -16,6 +16,7 @@ HTMLSRC= #JAVASRC=$(addprefix ./java-src/, ) LUASRC=$(addprefix ./lua-src/,allegro.lua test.lua) MAKESRC=$(addprefix ./make-src/,Makefile) +MERCSRC=$(addprefix ./merc-src/,accumulator.m) OBJCSRC=$(addprefix ./objc-src/,Subprocess.h Subprocess.m PackInsp.h PackInsp.m) OBJCPPSRC=$(addprefix ./objcpp-src/,SimpleCalc.H SimpleCalc.M) PASSRC=$(addprefix ./pas-src/,common.pas) @@ -32,7 +33,7 @@ YSRC= SRCS=${ADASRC} ${ASRC} ${CSRC} ${CPSRC} ${ELSRC} ${ERLSRC} ${FSRC}\ ${FORTHSRC} ${GOSRC} ${HTMLSRC} ${JAVASRC} ${LUASRC} ${MAKESRC}\ ${OBJCSRC} ${OBJCPPSRC} ${PASSRC} ${PHPSRC} ${PERLSRC} ${PSSRC}\ - ${PROLSRC} ${PYTSRC} ${RBSRC} ${RSSRC} ${SCMSRC} ${TEXSRC} ${YSRC} + ${PROLSRC} ${PYTSRC} ${RBSRC} ${RSSRC} ${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/accumulator.m b/test/manual/etags/merc-src/accumulator.m new file mode 100644 index 0000000000..94a6b1d858 --- /dev/null +++ b/test/manual/etags/merc-src/accumulator.m @@ -0,0 +1,1954 @@ +%---------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% +% Copyright (C) 1999-2000,2002-2007, 2009-2012 The University of Melbourne. +% Copyright (C) 2015 The Mercury team. +% This file may only be copied under the terms of the GNU General +% Public License - see the file COPYING in the Mercury distribution. +%---------------------------------------------------------------------------% +% +% Module: accumulator.m. +% Main authors: petdr. +% +% Attempts to transform a single proc to a tail recursive form by +% introducing accumulators. The algorithm can do this if the code after +% the recursive call has either the order independent state update or +% associative property. +% +% /* Order independent State update property */ +% :- promise all [A,B,S0,S] +% ( +% (some[SA] (update(A, S0, SA), update(B, SA, S))) +% <=> +% (some[SB] (update(B, S0, SB), update(A, SB, S))) +% ). +% +% /* Associativity property */ +% :- promise all [A,B,C,ABC] +% ( +% (some[AB] (assoc(A, B, AB), assoc(AB, C, ABC))) +% <=> +% (some[BC] (assoc(B, C, BC), assoc(A, BC, ABC))) +% ). +% +% XXX What about exceptions and non-termination? +% +% The promise declarations above only provide promises about the declarative +% semantics, but in order to apply this optimization, we ought to check that +% it will preserve the operational semantics (modulo whatever changes are +% allowed by the language semantics options). +% +% Currently we check and respect the --fully-strict option, but not the +% --no-reorder-conj option. XXX we should check --no-reorder-conj! +% If --no-reorder-conj was set, it would still be OK to apply this +% transformation, but ONLY in cases where the goals which get reordered +% are guaranteed not to throw any exceptions. +% +% The algorithm implemented is a combination of the algorithms from +% "Making Mercury Programs Tail Recursive" and +% "State Update Transformation", which can be found at +% <http://www.cs.mu.oz.au/research/mercury/information/papers.html>. +% +% Note that currently "State Update Transformation" paper only resides +% in CVS papers archive in the directory update, but has been submitted +% to PPDP '00. +% +% The transformation recognises predicates in the form +% +% p(In, OutUpdate, OutAssoc) :- +% minimal(In), +% initialize(OutUpdate), +% base(OutAssoc). +% p(In, OutUpdate, OutAssoc) :- +% decompose(In, Current, Rest), +% p(Rest, OutUpdate0, OutAssoc0), +% update(Current, OutUpdate0, OutUpdate), +% assoc(Current, OutAssoc0, OutAssoc). +% +% which can be transformed by the algorithm in "State Update Transformation" to +% +% p(In, OutUpdate, OutAssoc) :- +% initialize(AccUpdate), +% p_acc(In, OutUpdate, OutAssoc, AccUpdate). +% +% p_acc(In, OutUpdate, OutAssoc, AccUpdate) :- +% minimal(In), +% base(OutAssoc), +% OutUpdate = AccUpdate. +% p_acc(In, OutUpdate, OutAssoc, AccUpdate0) :- +% decompose(In, Current, Rest), +% update(Current, AccUpdate0, AccUpdate), +% p_acc(Rest, OutUpdate, OutAssoc0, AccUpdate), +% assoc(Current, OutAssoc0, OutAssoc). +% +% we then apply the algorithm from "Making Mercury Programs Tail Recursive" +% to p_acc to obtain +% +% p_acc(In, OutUpdate, OutAssoc, AccUpdate) :- +% minimal(In), +% base(OutAssoc), +% OutUpdate = AccUpdate. +% p_acc(In, OutUpdate, OutAssoc, AccUpdate0) :- +% decompose(In, Current, Rest), +% update(Current, AccUpdate0, AccUpdate), +% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, Current). +% +% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :- +% minimal(In), +% base(Base), +% assoc(AccAssoc0, Base, OutAssoc), +% OutUpdate = AccUpdate0. +% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :- +% decompose(In, Current, Rest), +% update(Current, AccUpdate0, AccUpdate), +% assoc(AccAssoc0, Current, AccAssoc), +% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, AccAssoc). +% +% p_acc is no longer recursive and is only ever called from p, so we +% inline p_acc into p to obtain the final schema. +% +% p(In, OutUpdate, OutAssoc) :- +% minimal(In), +% base(OutAssoc), +% initialize(AccUpdate), +% OutUpdate = AccUpdate. +% p(In, OutUpdate, OutAssoc) :- +% decompose(In, Current, Rest), +% initialize(AccUpdate0), +% update(Current, AccUpdate0, AccUpdate), +% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, Current). +% +% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :- +% minimal(In), +% base(Base), +% assoc(AccAssoc0, Base, OutAssoc), +% OutUpdate = AccUpdate0. +% p_acc2(In, OutUpdate, OutAssoc, AccUpdate0, AccAssoc0) :- +% decompose(In, Current, Rest), +% update(Current, AccUpdate0, AccUpdate), +% assoc(AccAssoc0, Current, AccAssoc), +% p_acc2(Rest, OutUpdate, OutAssoc, AccUpdate, AccAssoc). +% +% The only real difficulty in this new transformation is identifying the +% initialize/1 and base/1 goals from the original base case. +% +% Note that if the recursive clause contains multiple calls to p, the +% transformation attempts to move each recursive call to the end +% until one succeeds. This makes the order of independent recursive +% calls in the body irrelevant. +% +% XXX Replace calls to can_reorder_goals with calls to the version that +% use the intermodule-analysis framework. +% +%---------------------------------------------------------------------------% + +:- module transform_hlds.accumulator. +:- interface. + +:- import_module hlds. +:- import_module hlds.hlds_module. +:- import_module hlds.hlds_pred. + +:- import_module univ. + + % Attempt to transform a procedure into accumulator recursive form. + % If we succeed, we will add the recursive version of the procedure + % to the module_info. However, we may also encounter errors, which + % we will add to the list of error_specs in the univ accumulator. + % +:- pred accu_transform_proc(pred_proc_id::in, pred_info::in, + proc_info::in, proc_info::out, module_info::in, module_info::out, + univ::in, univ::out) is det. + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- implementation. + +:- import_module hlds.assertion. +:- import_module hlds.goal_util. +:- import_module hlds.hlds_error_util. +:- import_module hlds.hlds_goal. +:- import_module hlds.hlds_out. +:- import_module hlds.hlds_out.hlds_out_util. +:- import_module hlds.hlds_promise. +:- import_module hlds.instmap. +:- import_module hlds.pred_table. +:- import_module hlds.quantification. +:- import_module hlds.status. +:- import_module hlds.vartypes. +:- import_module libs. +:- import_module libs.globals. +:- import_module libs.optimization_options. +:- import_module libs.options. +:- import_module mdbcomp. +:- import_module mdbcomp.sym_name. +:- import_module parse_tree. +:- import_module parse_tree.error_util. +:- import_module parse_tree.prog_data. +:- import_module parse_tree.prog_mode. +:- import_module parse_tree.prog_util. +:- import_module parse_tree.set_of_var. +:- import_module transform_hlds.goal_store. + +:- import_module assoc_list. +:- import_module bool. +:- import_module int. +:- import_module io. +:- import_module list. +:- import_module map. +:- import_module maybe. +:- import_module pair. +:- import_module require. +:- import_module set. +:- import_module solutions. +:- import_module string. +:- import_module term. +:- import_module varset. + +%---------------------------------------------------------------------------% + + % The form of the goal around the base and recursive cases. + % +:- type top_level + ---> switch_base_rec + ; switch_rec_base + ; disj_base_rec + ; disj_rec_base + ; ite_base_rec + ; ite_rec_base. + + % An accu_goal_id represents a goal. The first field says which conjunction + % the goal came from (the base case or the recursive case), and the second + % gives the location of the goal in that conjunction. + % +:- type accu_goal_id + ---> accu_goal_id(accu_case, int). + +:- type accu_case + ---> accu_base + ; accu_rec. + + % The goal_store associates a goal with each goal_id. + % +:- type accu_goal_store == goal_store(accu_goal_id). + + % A substitution from the first variable name to the second. + % +:- type accu_subst == map(prog_var, prog_var). + +:- type accu_warning + ---> accu_warn(prog_context, pred_id, prog_var, prog_var). + % Warn that two prog_vars in a call to pred_id at the given context + % were swapped, which may cause an efficiency problem. + +%---------------------------------------------------------------------------% + +accu_transform_proc(proc(PredId, ProcId), PredInfo, !ProcInfo, !ModuleInfo, + !Cookie) :- + module_info_get_globals(!.ModuleInfo, Globals), + globals.get_opt_tuple(Globals, OptTuple), + DoLCMC = OptTuple ^ ot_opt_lcmc_accumulator, + globals.lookup_bool_option(Globals, fully_strict, FullyStrict), + ( if + should_attempt_accu_transform(!ModuleInfo, PredId, ProcId, PredInfo, + !ProcInfo, FullyStrict, DoLCMC, Warnings) + then + globals.lookup_bool_option(Globals, very_verbose, VeryVerbose), + ( + VeryVerbose = yes, + trace [io(!IO)] ( + module_info_get_name(!.ModuleInfo, ModuleName), + get_progress_output_stream(Globals, ModuleName, + ProgressStream, !IO), + PredStr = pred_id_to_string(!.ModuleInfo, PredId), + io.format(ProgressStream, + "%% Accumulators introduced into %s\n", [s(PredStr)], !IO) + ) + ; + VeryVerbose = no + ), + + ( + Warnings = [] + ; + Warnings = [_ | _], + pred_info_get_context(PredInfo, Context), + PredPieces = describe_one_pred_name(!.ModuleInfo, + should_module_qualify, PredId), + InPieces = [words("In") | PredPieces] ++ [suffix(":"), nl], + InMsg = simple_msg(Context, + [option_is_set(warn_accumulator_swaps, yes, + [always(InPieces)])]), + + proc_info_get_varset(!.ProcInfo, VarSet), + generate_warnings(!.ModuleInfo, VarSet, Warnings, WarnMsgs), + ( + Warnings = [_], + EnsurePieces = [words("Please ensure that this"), + words("argument rearrangement does not introduce"), + words("performance problems.")] + ; + Warnings = [_, _ | _], + EnsurePieces = [words("Please ensure that these"), + words("argument rearrangements do not introduce"), + words("performance problems.")] + ), + SuppressPieces = + [words("These warnings can be suppressed by"), + quote("--no-warn-accumulator-swaps"), suffix(".")], + VerbosePieces = [words("If a predicate has been declared"), + words("associative"), + words("via a"), quote("promise"), words("declaration,"), + words("the compiler will rearrange the order of"), + words("the arguments in calls to that predicate,"), + words("if by so doing it makes the containing predicate"), + words("tail recursive. In such situations, the compiler"), + words("will issue this warning. If this reordering"), + words("changes the performance characteristics"), + words("of the call to the predicate, use"), + quote("--no-accumulator-introduction"), + words("to turn the optimization off, or "), + quote("--no-warn-accumulator-swaps"), + words("to turn off the warnings.")], + EnsureSuppressMsg = simple_msg(Context, + [option_is_set(warn_accumulator_swaps, yes, + [always(EnsurePieces), always(SuppressPieces)]), + verbose_only(verbose_once, VerbosePieces)]), + Severity = severity_conditional(warn_accumulator_swaps, yes, + severity_warning, no), + Msgs = [InMsg | WarnMsgs] ++ [EnsureSuppressMsg], + Spec = error_spec($pred, Severity, phase_accumulator_intro, Msgs), + + det_univ_to_type(!.Cookie, Specs0), + Specs = [Spec | Specs0], + type_to_univ(Specs, !:Cookie) + ) + else + true + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- pred generate_warnings(module_info::in, prog_varset::in, + list(accu_warning)::in, list(error_msg)::out) is det. + +generate_warnings(_, _, [], []). +generate_warnings(ModuleInfo, VarSet, [Warning | Warnings], [Msg | Msgs]) :- + generate_warning(ModuleInfo, VarSet, Warning, Msg), + generate_warnings(ModuleInfo, VarSet, Warnings, Msgs). + +:- pred generate_warning(module_info::in, prog_varset::in, accu_warning::in, + error_msg::out) is det. + +generate_warning(ModuleInfo, VarSet, Warning, Msg) :- + Warning = accu_warn(Context, PredId, VarA, VarB), + PredPieces = describe_one_pred_name(ModuleInfo, should_module_qualify, + PredId), + + varset.lookup_name(VarSet, VarA, VarAName), + varset.lookup_name(VarSet, VarB, VarBName), + + Pieces = [words("warning: the call to")] ++ PredPieces ++ + [words("has had the location of the variables"), + quote(VarAName), words("and"), quote(VarBName), + words("swapped to allow accumulator introduction."), nl], + Msg = simplest_msg(Context, Pieces). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % should_attempt_accu_transform is only true iff the current proc + % has been transformed to call the newly created accumulator proc. + % +:- pred should_attempt_accu_transform(module_info::in, module_info::out, + pred_id::in, proc_id::in, pred_info::in, proc_info::in, proc_info::out, + bool::in, maybe_opt_lcmc_accumulator::in, + list(accu_warning)::out) is semidet. + +should_attempt_accu_transform(!ModuleInfo, PredId, ProcId, PredInfo, + !ProcInfo, FullyStrict, DoLCMC, Warnings) :- + proc_info_get_goal(!.ProcInfo, Goal0), + proc_info_get_headvars(!.ProcInfo, HeadVars), + proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InitialInstMap), + accu_standardize(Goal0, Goal), + identify_goal_type(PredId, ProcId, Goal, InitialInstMap, + TopLevel, Base, BaseInstMap, Rec, RecInstMap), + + C = initialize_goal_store(Rec, RecInstMap, Base, BaseInstMap), + identify_recursive_calls(PredId, ProcId, C, RecCallIds), + list.length(Rec, M), + + should_attempt_accu_transform_2(!ModuleInfo, PredId, PredInfo, !ProcInfo, + HeadVars, InitialInstMap, TopLevel, FullyStrict, DoLCMC, + RecCallIds, C, M, Rec, Warnings). + + % should_attempt_accu_transform_2 takes a list of locations of the + % recursive calls, and attempts to introduce accumulator into each of the + % recursive calls, stopping at the first one that succeeds. + % This catches the following case, as selecting the first recursive call + % allows the second recursive call to be moved before it, and + % OutA is in the correct spot in list.append. + % + % p(InA, OutA), + % p(InB, OutB), + % list.append(OutB, OutA, Out) + % +:- pred should_attempt_accu_transform_2(module_info::in, module_info::out, + pred_id::in, pred_info::in, proc_info::in, proc_info::out, + list(prog_var)::in, instmap::in, top_level::in, bool::in, + maybe_opt_lcmc_accumulator::in, + list(accu_goal_id)::in, accu_goal_store::in, int::in, list(hlds_goal)::in, + list(accu_warning)::out) is semidet. + +should_attempt_accu_transform_2(!ModuleInfo, PredId, PredInfo, !ProcInfo, + HeadVars, InitialInstMap, TopLevel, FullyStrict, DoLCMC, + [Id | Ids], C, M, Rec, Warnings) :- + proc_info_get_vartypes(!.ProcInfo, VarTypes0), + identify_out_and_out_prime(!.ModuleInfo, VarTypes0, InitialInstMap, + Id, Rec, HeadVars, Out, OutPrime, HeadToCallSubst, CallToHeadSubst), + ( if + accu_stage1(!.ModuleInfo, VarTypes0, FullyStrict, DoLCMC, Id, M, C, + Sets), + accu_stage2(!.ModuleInfo, !.ProcInfo, Id, C, Sets, OutPrime, Out, + VarSet, VarTypes, Accs, BaseCase, BasePairs, Substs, CS, + WarningsPrime), + accu_stage3(Id, Accs, VarSet, VarTypes, C, CS, Substs, + HeadToCallSubst, CallToHeadSubst, BaseCase, BasePairs, Sets, Out, + TopLevel, PredId, PredInfo, !ProcInfo, !ModuleInfo) + then + Warnings = WarningsPrime + else + should_attempt_accu_transform_2(!ModuleInfo, PredId, PredInfo, + !ProcInfo, HeadVars, InitialInstMap, TopLevel, FullyStrict, DoLCMC, + Ids, C, M, Rec, Warnings) + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % Transform the goal into a standard form that is amenable to + % introducing accumulators. + % + % At the moment all this does is remove any extra disj/conj wrappers + % around the top level goal. + % + % Future work is for this code to rearrange code with multiple base + % and recursive cases into a single base and recursive case. + % +:- pred accu_standardize(hlds_goal::in, hlds_goal::out) is det. + +accu_standardize(Goal0, Goal) :- + ( if + Goal0 = hlds_goal(GoalExpr0, _), + ( + GoalExpr0 = conj(plain_conj, [Goal1]) + ; + GoalExpr0 = disj([Goal1]) + ) + then + accu_standardize(Goal1, Goal) + else + Goal = Goal0 + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % This predicate takes the original goal and identifies the `shape' + % of the goal around the recursive and base cases. + % + % Note that the base case can contain a recursive call, as the + % transformation doesn't depend on what is in the base case. + % +:- pred identify_goal_type(pred_id::in, proc_id::in, hlds_goal::in, + instmap::in, top_level::out, list(hlds_goal)::out, instmap::out, + list(hlds_goal)::out, instmap::out) is semidet. + +identify_goal_type(PredId, ProcId, Goal, InitialInstMap, Type, + Base, BaseInstMap, Rec, RecInstMap) :- + Goal = hlds_goal(GoalExpr, _GoalInfo), + ( + GoalExpr = switch(_Var, _CanFail, Cases), + ( if + Cases = [case(_IdA, [], GoalA), case(_IdB, [], GoalB)], + goal_to_conj_list(GoalA, GoalAList), + goal_to_conj_list(GoalB, GoalBList) + then + ( if is_recursive_case(GoalAList, proc(PredId, ProcId)) then + Type = switch_rec_base, + Base = GoalBList, + Rec = GoalAList + else if is_recursive_case(GoalBList, proc(PredId, ProcId)) then + Type = switch_base_rec, + Base = GoalAList, + Rec = GoalBList + else + fail + ), + BaseInstMap = InitialInstMap, + RecInstMap = InitialInstMap + else + fail + ) + ; + GoalExpr = disj(Goals), + ( if + Goals = [GoalA, GoalB], + goal_to_conj_list(GoalA, GoalAList), + goal_to_conj_list(GoalB, GoalBList) + then + ( if is_recursive_case(GoalAList, proc(PredId, ProcId)) then + Type = disj_rec_base, + Base = GoalBList, + Rec = GoalAList + else if is_recursive_case(GoalBList, proc(PredId, ProcId)) then + Type = disj_base_rec, + Base = GoalAList, + Rec = GoalBList + else + fail + ), + BaseInstMap = InitialInstMap, + RecInstMap = InitialInstMap + else + fail + ) + ; + GoalExpr = if_then_else(_Vars, Cond, Then, Else), + Cond = hlds_goal(_CondGoalExpr, CondGoalInfo), + CondInstMapDelta = goal_info_get_instmap_delta(CondGoalInfo), + + goal_to_conj_list(Then, GoalAList), + goal_to_conj_list(Else, GoalBList), + ( if is_recursive_case(GoalAList, proc(PredId, ProcId)) then + Type = ite_rec_base, + Base = GoalBList, + Rec = GoalAList, + + BaseInstMap = InitialInstMap, + apply_instmap_delta(CondInstMapDelta, InitialInstMap, RecInstMap) + else if is_recursive_case(GoalBList, proc(PredId, ProcId)) then + Type = ite_base_rec, + Base = GoalAList, + Rec = GoalBList, + + RecInstMap = InitialInstMap, + apply_instmap_delta(CondInstMapDelta, InitialInstMap, BaseInstMap) + else + fail + ) + ). + + % is_recursive_case(Gs, Id) is true iff the list of goals, Gs, + % contains a call to the procedure specified by Id, where the call + % is located in a position that can be used by the transformation + % (i.e. not hidden in a compound goal). + % +:- pred is_recursive_case(list(hlds_goal)::in, pred_proc_id::in) is semidet. + +is_recursive_case(Goals, proc(PredId, ProcId)) :- + list.append(_Initial, [RecursiveCall | _Final], Goals), + RecursiveCall = hlds_goal(plain_call(PredId, ProcId, _, _, _, _), _). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % The store info is folded over the list of goals which + % represent the base and recursive case conjunctions. +:- type store_info + ---> store_info( + store_loc :: int, + % The location of the goal in the conjunction. + store_instmap :: instmap, + store_goals :: accu_goal_store + ). + + % Initialise the goal_store, which will hold the C_{a,b} goals. + % +:- func initialize_goal_store(list(hlds_goal), instmap, + list(hlds_goal), instmap) = accu_goal_store. + +initialize_goal_store(Rec, RecInstMap, Base, BaseInstMap) = C :- + goal_store_init(C0), + list.foldl3(accu_store(accu_rec), Rec, + 1, _, RecInstMap, _, C0, C1), + list.foldl3(accu_store(accu_base), Base, + 1, _, BaseInstMap, _, C1, C). + +:- pred accu_store(accu_case::in, hlds_goal::in, + int::in, int::out, instmap::in, instmap::out, + accu_goal_store::in, accu_goal_store::out) is det. + +accu_store(Case, Goal, !N, !InstMap, !GoalStore) :- + Id = accu_goal_id(Case, !.N), + goal_store_det_insert(Id, stored_goal(Goal, !.InstMap), !GoalStore), + + !:N = !.N + 1, + Goal = hlds_goal(_, GoalInfo), + InstMapDelta = goal_info_get_instmap_delta(GoalInfo), + apply_instmap_delta(InstMapDelta, !InstMap). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % Determine the k's which are recursive calls. + % Note that this doesn't find recursive calls which are `hidden' + % in compound goals, this is not a problem as currently we can't use + % these to do transformation. + % +:- pred identify_recursive_calls(pred_id::in, proc_id::in, + accu_goal_store::in, list(accu_goal_id)::out) is det. + +identify_recursive_calls(PredId, ProcId, GoalStore, Ids) :- + P = + ( pred(Key::out) is nondet :- + goal_store_member(GoalStore, Key, stored_goal(Goal, _InstMap)), + Key = accu_goal_id(accu_rec, _), + Goal = hlds_goal(plain_call(PredId, ProcId, _, _, _, _), _) + ), + solutions.solutions(P, Ids). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % Determine the variables which are members of the sets Out and Out', + % and initialize the substitutions between the two sets. + % + % This is done by identifing those variables whose instantiatedness change + % in the goals after the recursive call and are headvars. + % + % Note that we are only identifying the output variables which will need + % to be accumulated, as there may be other output variables which are + % produced prior to the recursive call. + % +:- pred identify_out_and_out_prime(module_info::in, vartypes::in, instmap::in, + accu_goal_id::in, list(hlds_goal)::in, + list(prog_var)::in, list(prog_var)::out, list(prog_var)::out, + accu_subst::out, accu_subst::out) is det. + +identify_out_and_out_prime(ModuleInfo, VarTypes, InitialInstMap, GoalId, + Rec, HeadVars, Out, OutPrime, HeadToCallSubst, CallToHeadSubst) :- + GoalId = accu_goal_id(_Case, K), + ( if + list.take(K, Rec, InitialGoals), + list.drop(K-1, Rec, FinalGoals), + FinalGoals = [hlds_goal(plain_call(_, _, Args, _, _, _), _) | Rest] + then + goal_list_instmap_delta(InitialGoals, InitInstMapDelta), + apply_instmap_delta( InitInstMapDelta, + InitialInstMap, InstMapBeforeRest), + + goal_list_instmap_delta(Rest, InstMapDelta), + apply_instmap_delta(InstMapDelta, InstMapBeforeRest, InstMapAfterRest), + + instmap_changed_vars(ModuleInfo, VarTypes, + InstMapBeforeRest, InstMapAfterRest, ChangedVars), + + assoc_list.from_corresponding_lists(HeadVars, Args, HeadArg0), + + Member = + ( pred(M::in) is semidet :- + M = HeadVar - _, + set_of_var.member(ChangedVars, HeadVar) + ), + list.filter(Member, HeadArg0, HeadArg), + list.map(fst, HeadArg, Out), + list.map(snd, HeadArg, OutPrime), + + map.from_assoc_list(HeadArg, HeadToCallSubst), + + list.map((pred(X-Y::in, Y-X::out) is det), HeadArg, ArgHead), + map.from_assoc_list(ArgHead, CallToHeadSubst) + else + unexpected($pred, "test failed") + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % For each goal after the recursive call, we place that goal + % into a set according to what properties that goal has. + % For the definition of what goes into each set, inspect the documentation + % for the functions named before, assoc, and so on. + % +:- type accu_sets + ---> accu_sets( + as_before :: set(accu_goal_id), + as_assoc :: set(accu_goal_id), + as_construct_assoc :: set(accu_goal_id), + as_construct :: set(accu_goal_id), + as_update :: set(accu_goal_id), + as_reject :: set(accu_goal_id) + ). + + % Stage 1 is responsible for identifying which goals are associative, + % which can be moved before the recursive call and so on. + % +:- pred accu_stage1(module_info::in, vartypes::in, bool::in, + maybe_opt_lcmc_accumulator::in, accu_goal_id::in, int::in, + accu_goal_store::in, accu_sets::out) is semidet. + +accu_stage1(ModuleInfo, VarTypes, FullyStrict, DoLCMC, GoalId, M, GoalStore, + Sets) :- + GoalId = accu_goal_id(Case, K), + NextGoalId = accu_goal_id(Case, K + 1), + accu_sets_init(Sets0), + accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M, + GoalStore, Sets0, Sets1), + Sets1 = accu_sets(Before, Assoc, + ConstructAssoc, Construct, Update, Reject), + Sets = accu_sets(Before `set.union` set_upto(Case, K - 1), Assoc, + ConstructAssoc, Construct, Update, Reject), + + % Continue the transformation only if the set reject is empty and + % the set assoc or update contains something that needs to be moved + % before the recursive call. + set.is_empty(Reject), + ( + not set.is_empty(Assoc) + ; + not set.is_empty(Update) + ), + ( + DoLCMC = do_not_opt_lcmc_accumulator, + % If LCMC is not turned on, then there must be no construction + % unifications after the recursive call. + set.is_empty(Construct), + set.is_empty(ConstructAssoc) + ; + DoLCMC = opt_lcmc_accumulator + ). + + % For each goal after the recursive call decide which set + % the goal belongs to. + % +:- pred accu_stage1_2(module_info::in, vartypes::in, bool::in, + accu_goal_id::in, int::in, int::in, accu_goal_store::in, + accu_sets::in, accu_sets::out) is det. + +accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, GoalId, K, M, GoalStore, + !Sets) :- + GoalId = accu_goal_id(Case, I), + NextGoalId = accu_goal_id(Case, I + 1), + ( if I > M then + true + else + ( if + accu_before(ModuleInfo, VarTypes, FullyStrict, GoalId, K, + GoalStore, !.Sets) + then + !Sets ^ as_before := set.insert(!.Sets ^ as_before, GoalId), + accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M, + GoalStore, !Sets) + else if + accu_assoc(ModuleInfo, VarTypes, FullyStrict, GoalId, K, + GoalStore, !.Sets) + then + !Sets ^ as_assoc := set.insert(!.Sets ^ as_assoc, GoalId), + accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M, + GoalStore, !Sets) + else if + accu_construct(ModuleInfo, VarTypes, FullyStrict, GoalId, K, + GoalStore, !.Sets) + then + !Sets ^ as_construct := set.insert(!.Sets ^ as_construct, GoalId), + accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M, + GoalStore, !Sets) + else if + accu_construct_assoc(ModuleInfo, VarTypes, FullyStrict, GoalId, K, + GoalStore, !.Sets) + then + !Sets ^ as_construct_assoc := + set.insert(!.Sets ^ as_construct_assoc, GoalId), + accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M, + GoalStore, !Sets) + else if + accu_update(ModuleInfo, VarTypes, FullyStrict, GoalId, K, + GoalStore, !.Sets) + then + !Sets ^ as_update := set.insert(!.Sets ^ as_update, GoalId), + accu_stage1_2(ModuleInfo, VarTypes, FullyStrict, NextGoalId, K, M, + GoalStore, !Sets) + else + !Sets ^ as_reject := set.insert(!.Sets ^ as_reject, GoalId) + ) + ). + +%---------------------------------------------------------------------------% + +:- pred accu_sets_init(accu_sets::out) is det. + +accu_sets_init(Sets) :- + set.init(EmptySet), + Before = EmptySet, + Assoc = EmptySet, + ConstructAssoc = EmptySet, + Construct = EmptySet, + Update = EmptySet, + Reject = EmptySet, + Sets = accu_sets(Before, Assoc, ConstructAssoc, Construct, Update, Reject). + + % set_upto(Case, K) returns the set + % {accu_goal_id(Case, 1) .. accu_goal_id(Case, K)}. + % +:- func set_upto(accu_case, int) = set(accu_goal_id). + +set_upto(Case, K) = Set :- + ( if K =< 0 then + set.init(Set) + else + Set0 = set_upto(Case, K - 1), + set.insert(accu_goal_id(Case, K), Set0, Set) + ). + +%---------------------------------------------------------------------------% + + % A goal is a member of the before set iff the goal only depends on goals + % which are before the recursive call or can be moved before the recursive + % call (member of the before set). + % +:- pred accu_before(module_info::in, vartypes::in, bool::in, + accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet. + +accu_before(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore, Sets) :- + GoalId = accu_goal_id(Case, _I), + Before = Sets ^ as_before, + goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)), + ( + member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId, + stored_goal(EarlierGoal, EarlierInstMap)), + not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict, + EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal) + ) + => + ( + set.member(LessThanGoalId, set_upto(Case, K - 1) `union` Before) + ). + + % A goal is a member of the assoc set iff the goal only depends on goals + % upto and including the recursive call and goals which can be moved + % before the recursive call (member of the before set) AND the goal + % is associative. + % +:- pred accu_assoc(module_info::in, vartypes::in, bool::in, + accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet. + +accu_assoc(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore, Sets) :- + GoalId = accu_goal_id(Case, _I), + Before = Sets ^ as_before, + goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)), + LaterGoal = hlds_goal(plain_call(PredId, _, Args, _, _, _), _), + accu_is_associative(ModuleInfo, PredId, Args, _), + ( + % XXX LessThanGoalId was _N - J, not N - J: it ignored the case. + % See the diff with the previous version. + member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId, + stored_goal(EarlierGoal, EarlierInstMap)), + not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict, + EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal) + ) + => + ( + set.member(LessThanGoalId, set_upto(Case, K) `union` Before) + ). + + % A goal is a member of the construct set iff the goal only depends + % on goals upto and including the recursive call and goals which + % can be moved before the recursive call (member of the before set) + % AND the goal is construction unification. + % +:- pred accu_construct(module_info::in, vartypes::in, bool::in, + accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet. + +accu_construct(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore, + Sets) :- + GoalId = accu_goal_id(Case, _I), + Before = Sets ^ as_before, + Construct = Sets ^ as_construct, + goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)), + LaterGoal = hlds_goal(unify(_, _, _, Unify, _), _GoalInfo), + Unify = construct(_, _, _, _, _, _, _), + ( + % XXX LessThanGoalId was _N - J, not N - J: it ignored the case. + % See the diff with the previous version. + member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId, + stored_goal(EarlierGoal, EarlierInstMap)), + not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict, + EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal) + ) + => + ( + set.member(LessThanGoalId, + set_upto(Case, K) `union` Before `union` Construct) + ). + + % A goal is a member of the construct_assoc set iff the goal depends only + % on goals upto and including the recursive call and goals which can be + % moved before the recursive call (member of the before set) and goals + % which are associative AND the goal is construction unification AND + % there is only one member of the assoc set which the construction + % unification depends on AND the construction unification can be expressed + % as a call to the member of the assoc set which the construction + % unification depends on. + % +:- pred accu_construct_assoc(module_info::in, vartypes::in, bool::in, + accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet. + +accu_construct_assoc(ModuleInfo, VarTypes, FullyStrict, + GoalId, K, GoalStore, Sets) :- + GoalId = accu_goal_id(Case, _I), + Before = Sets ^ as_before, + Assoc = Sets ^ as_assoc, + ConstructAssoc = Sets ^ as_construct_assoc, + goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)), + LaterGoal = hlds_goal(unify(_, _, _, Unify, _), _GoalInfo), + Unify = construct(_, ConsId, _, _, _, _, _), + + goal_store_all_ancestors(GoalStore, GoalId, VarTypes, ModuleInfo, + FullyStrict, Ancestors), + + set.is_singleton(Assoc `intersect` Ancestors, AssocId), + goal_store_lookup(GoalStore, AssocId, + stored_goal(AssocGoal, _AssocInstMap)), + AssocGoal = hlds_goal(plain_call(PredId, _, _, _, _, _), _), + + is_associative_construction(ModuleInfo, PredId, ConsId), + ( + % XXX LessThanGoalId was _N - J, not N - J: it ignored the case. + % See the diff with the previous version. + member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId, + stored_goal(EarlierGoal, EarlierInstMap)), + not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict, + EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal) + ) + => + ( + set.member(LessThanGoalId, + set_upto(Case, K) `union` Before `union` Assoc + `union` ConstructAssoc) + ). + + % A goal is a member of the update set iff the goal only depends + % on goals upto and including the recursive call and goals which + % can be moved before the recursive call (member of the before set) + % AND the goal updates some state. + % +:- pred accu_update(module_info::in, vartypes::in, bool::in, + accu_goal_id::in, int::in, accu_goal_store::in, accu_sets::in) is semidet. + +accu_update(ModuleInfo, VarTypes, FullyStrict, GoalId, K, GoalStore, Sets) :- + GoalId = accu_goal_id(Case, _I), + Before = Sets ^ as_before, + goal_store_lookup(GoalStore, GoalId, stored_goal(LaterGoal, LaterInstMap)), + LaterGoal = hlds_goal(plain_call(PredId, _, Args, _, _, _), _), + accu_is_update(ModuleInfo, PredId, Args, _), + ( + % XXX LessThanGoalId was _N - J, not N - J: it ignored the case. + % See the diff with the previous version. + member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId, + stored_goal(EarlierGoal, EarlierInstMap)), + not can_reorder_goals_old(ModuleInfo, VarTypes, FullyStrict, + EarlierInstMap, EarlierGoal, LaterInstMap, LaterGoal) + ) + => + ( + set.member(LessThanGoalId, set_upto(Case, K) `union` Before) + ). + + % member_lessthan_goalid(GS, IdA, IdB, GB) is true iff the goal_id, IdB, + % and its associated goal, GB, is a member of the goal_store, GS, + % and IdB is less than IdA. + % +:- pred member_lessthan_goalid(accu_goal_store::in, + accu_goal_id::in, accu_goal_id::out, stored_goal::out) is nondet. + +member_lessthan_goalid(GoalStore, GoalId, LessThanGoalId, LessThanGoal) :- + goal_store_member(GoalStore, LessThanGoalId, LessThanGoal), + GoalId = accu_goal_id(Case, I), + LessThanGoalId = accu_goal_id(Case, J), + J < I. + +%---------------------------------------------------------------------------% + +:- type accu_assoc + ---> accu_assoc( + set_of_progvar, % the associative input args + prog_var, % the corresponding output arg + bool % is the predicate commutative? + ). + + % If accu_is_associative is true, it returns the two arguments which are + % associative and the variable which depends on those two arguments, + % and an indicator of whether or not the predicate is commutative. + % +:- pred accu_is_associative(module_info::in, pred_id::in, list(prog_var)::in, + accu_assoc::out) is semidet. + +accu_is_associative(ModuleInfo, PredId, Args, Result) :- + module_info_pred_info(ModuleInfo, PredId, PredInfo), + pred_info_get_assertions(PredInfo, Assertions), + AssertionsList = set.to_sorted_list(Assertions), + associativity_assertion(ModuleInfo, AssertionsList, Args, + AssociativeVarsOutputVar), + ( if + commutativity_assertion(ModuleInfo, AssertionsList, Args, + _CommutativeVars) + then + IsCommutative = yes + else + IsCommutative = no + ), + AssociativeVarsOutputVar = + associative_vars_output_var(AssociativeVars, OutputVar), + Result = accu_assoc(AssociativeVars, OutputVar, IsCommutative). + + % Does there exist one (and only one) associativity assertion for the + % current predicate? + % The 'and only one condition' is required because we currently + % do not handle the case of predicates which have individual parts + % which are associative, because then we do not know which variable + % is descended from which. + % +:- pred associativity_assertion(module_info::in, list(assert_id)::in, + list(prog_var)::in, associative_vars_output_var::out) is semidet. + +associativity_assertion(ModuleInfo, [AssertId | AssertIds], Args0, + AssociativeVarsOutputVar) :- + ( if + assertion.is_associativity_assertion(ModuleInfo, AssertId, + Args0, AssociativeVarsOutputVarPrime) + then + AssociativeVarsOutputVar = AssociativeVarsOutputVarPrime, + not associativity_assertion(ModuleInfo, AssertIds, Args0, _) + else + associativity_assertion(ModuleInfo, AssertIds, Args0, + AssociativeVarsOutputVar) + ). + + % Does there exist one (and only one) commutativity assertion for the + % current predicate? + % The 'and only one condition' is required because we currently + % do not handle the case of predicates which have individual + % parts which are commutative, because then we do not know which variable + % is descended from which. + % +:- pred commutativity_assertion(module_info::in,list(assert_id)::in, + list(prog_var)::in, set_of_progvar::out) is semidet. + +commutativity_assertion(ModuleInfo, [AssertId | AssertIds], Args0, + CommutativeVars) :- + ( if + assertion.is_commutativity_assertion(ModuleInfo, AssertId, + Args0, CommutativeVarsPrime) + then + CommutativeVars = CommutativeVarsPrime, + not commutativity_assertion(ModuleInfo, AssertIds, Args0, _) + else + commutativity_assertion(ModuleInfo, AssertIds, Args0, + CommutativeVars) + ). + +%---------------------------------------------------------------------------% + + % Does the current predicate update some state? + % +:- pred accu_is_update(module_info::in, pred_id::in, list(prog_var)::in, + state_update_vars::out) is semidet. + +accu_is_update(ModuleInfo, PredId, Args, ResultStateVars) :- + module_info_pred_info(ModuleInfo, PredId, PredInfo), + pred_info_get_assertions(PredInfo, Assertions), + list.filter_map( + ( pred(AssertId::in, StateVars::out) is semidet :- + assertion.is_update_assertion(ModuleInfo, AssertId, + PredId, Args, StateVars) + ), + set.to_sorted_list(Assertions), Result), + % XXX Maybe we should just match on the first result, + % just in case there are duplicate promises. + Result = [ResultStateVars]. + +%---------------------------------------------------------------------------% + + % Can the construction unification be expressed as a call to the + % specified predicate. + % +:- pred is_associative_construction(module_info::in, pred_id::in, cons_id::in) + is semidet. + +is_associative_construction(ModuleInfo, PredId, ConsId) :- + module_info_pred_info(ModuleInfo, PredId, PredInfo), + pred_info_get_assertions(PredInfo, Assertions), + list.filter( + ( pred(AssertId::in) is semidet :- + assertion.is_construction_equivalence_assertion(ModuleInfo, + AssertId, ConsId, PredId) + ), + set.to_sorted_list(Assertions), Result), + Result = [_ | _]. + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- type accu_substs + ---> accu_substs( + acc_var_subst :: accu_subst, + rec_call_subst :: accu_subst, + assoc_call_subst :: accu_subst, + update_subst :: accu_subst + ). + +:- type accu_base + ---> accu_base( + % goals which initialize update + init_update :: set(accu_goal_id), + + % goals which initialize assoc + init_assoc :: set(accu_goal_id), + + % other goals + other :: set(accu_goal_id) + ). + + % Stage 2 is responsible for identifying the substitutions which + % are needed to mimic the unfold/fold process that was used as + % the justification of the algorithm in the paper. + % It is also responsible for ensuring that the reordering of arguments + % doesn't worsen the big-O complexity of the procedure. + % It also divides the base case into goals that initialize the + % variables used by the update goals, and those used by the assoc + % goals and then all the rest. + % +:- pred accu_stage2(module_info::in, proc_info::in, + accu_goal_id::in, accu_goal_store::in, accu_sets::in, + list(prog_var)::in, list(prog_var)::in, prog_varset::out, vartypes::out, + list(prog_var)::out, accu_base::out, list(pair(prog_var))::out, + accu_substs::out, accu_goal_store::out, list(accu_warning)::out) + is semidet. + +accu_stage2(ModuleInfo, ProcInfo0, GoalId, GoalStore, Sets, OutPrime, Out, + !:VarSet, !:VarTypes, Accs, BaseCase, BasePairs, !:Substs, + CS, Warnings) :- + Sets = accu_sets(Before0, Assoc, ConstructAssoc, Construct, Update, _), + GoalId = accu_goal_id(Case, K), + Before = Before0 `union` set_upto(Case, K-1), + + % Note Update set is not placed in the after set, as the after set is used + % to determine the variables that need to be accumulated for the + % associative calls. + After = Assoc `union` ConstructAssoc `union` Construct, + + P = + ( pred(Id::in, Set0::in, Set::out) is det :- + goal_store_lookup(GoalStore, Id, stored_goal(Goal, _InstMap)), + Goal = hlds_goal(_GoalExpr, GoalInfo), + NonLocals = goal_info_get_nonlocals(GoalInfo), + set_of_var.union(NonLocals, Set0, Set) + ), + list.foldl(P, set.to_sorted_list(Before), + set_of_var.init, BeforeNonLocals), + list.foldl(P, set.to_sorted_list(After), + set_of_var.init, AfterNonLocals), + InitAccs = set_of_var.intersect(BeforeNonLocals, AfterNonLocals), + + proc_info_get_varset(ProcInfo0, !:VarSet), + proc_info_get_vartypes(ProcInfo0, !:VarTypes), + + accu_substs_init(set_of_var.to_sorted_list(InitAccs), !VarSet, !VarTypes, + !:Substs), + + set_of_var.list_to_set(OutPrime, OutPrimeSet), + accu_process_assoc_set(ModuleInfo, GoalStore, set.to_sorted_list(Assoc), + OutPrimeSet, !Substs, !VarSet, !VarTypes, CS, Warnings), + + accu_process_update_set(ModuleInfo, GoalStore, set.to_sorted_list(Update), + OutPrimeSet, !Substs, !VarSet, !VarTypes, UpdateOut, UpdateAccOut, + BasePairs), + + Accs = set_of_var.to_sorted_list(InitAccs) ++ UpdateAccOut, + + accu_divide_base_case(ModuleInfo, !.VarTypes, GoalStore, UpdateOut, Out, + UpdateBase, AssocBase, OtherBase), + + BaseCase = accu_base(UpdateBase, AssocBase, OtherBase). + +%---------------------------------------------------------------------------% + +:- pred accu_substs_init(list(prog_var)::in, prog_varset::in, prog_varset::out, + vartypes::in, vartypes::out, accu_substs::out) is det. + +accu_substs_init(InitAccs, !VarSet, !VarTypes, Substs) :- + map.init(Subst), + acc_var_subst_init(InitAccs, !VarSet, !VarTypes, AccVarSubst), + RecCallSubst = Subst, + AssocCallSubst = Subst, + UpdateSubst = Subst, + Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst, + UpdateSubst). + + % Initialise the acc_var_subst to be from Var to A_Var where Var is a + % member of InitAccs and A_Var is a fresh variable of the same type of Var. + % +:- pred acc_var_subst_init(list(prog_var)::in, + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, + accu_subst::out) is det. + +acc_var_subst_init([], !VarSet, !VarTypes, map.init). +acc_var_subst_init([Var | Vars], !VarSet, !VarTypes, Subst) :- + create_new_var(Var, "A_", AccVar, !VarSet, !VarTypes), + acc_var_subst_init(Vars, !VarSet, !VarTypes, Subst0), + map.det_insert(Var, AccVar, Subst0, Subst). + + % Create a fresh variable which is the same type as the old variable + % and has the same name except that it begins with the prefix. + % +:- pred create_new_var(prog_var::in, string::in, prog_var::out, + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det. + +create_new_var(OldVar, Prefix, NewVar, !VarSet, !VarTypes) :- + varset.lookup_name(!.VarSet, OldVar, OldName), + string.append(Prefix, OldName, NewName), + varset.new_named_var(NewName, NewVar, !VarSet), + lookup_var_type(!.VarTypes, OldVar, Type), + add_var_type(NewVar, Type, !VarTypes). + +%---------------------------------------------------------------------------% + + % For each member of the assoc set determine the substitutions needed, + % and also check the efficiency of the procedure isn't worsened + % by reordering the arguments to a call. + % +:- pred accu_process_assoc_set(module_info::in, accu_goal_store::in, + list(accu_goal_id)::in, set_of_progvar::in, + accu_substs::in, accu_substs::out, + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, + accu_goal_store::out, list(accu_warning)::out) is semidet. + +accu_process_assoc_set(_ModuleInfo, _GS, [], _OutPrime, !Substs, + !VarSet, !VarTypes, CS, []) :- + goal_store_init(CS). +accu_process_assoc_set(ModuleInfo, GS, [Id | Ids], OutPrime, !Substs, + !VarSet, !VarTypes, CS, Warnings) :- + !.Substs = accu_substs(AccVarSubst, RecCallSubst0, AssocCallSubst0, + UpdateSubst), + + lookup_call(GS, Id, stored_goal(Goal, InstMap)), + + Goal = hlds_goal(plain_call(PredId, _, Args, _, _, _), GoalInfo), + accu_is_associative(ModuleInfo, PredId, Args, AssocInfo), + AssocInfo = accu_assoc(Vars, AssocOutput, IsCommutative), + OutPrimeVars = set_of_var.intersect(Vars, OutPrime), + set_of_var.is_singleton(OutPrimeVars, DuringAssocVar), + set_of_var.is_singleton(set_of_var.difference(Vars, OutPrimeVars), + BeforeAssocVar), + + map.lookup(AccVarSubst, BeforeAssocVar, AccVar), + create_new_var(BeforeAssocVar, "NewAcc_", NewAcc, !VarSet, !VarTypes), + + map.det_insert(DuringAssocVar, AccVar, AssocCallSubst0, AssocCallSubst1), + map.det_insert(AssocOutput, NewAcc, AssocCallSubst1, AssocCallSubst), + map.det_insert(DuringAssocVar, AssocOutput, RecCallSubst0, RecCallSubst1), + map.det_insert(BeforeAssocVar, NewAcc, RecCallSubst1, RecCallSubst), + + !:Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst, + UpdateSubst), + + % ONLY swap the order of the variables if the goal is + % associative and not commutative. + ( + IsCommutative = yes, + CSGoal = stored_goal(Goal, InstMap), + CurWarnings = [] + ; + IsCommutative = no, + + % Ensure that the reordering doesn't cause a efficiency problem. + module_info_pred_info(ModuleInfo, PredId, PredInfo), + ModuleName = pred_info_module(PredInfo), + PredName = pred_info_name(PredInfo), + Arity = pred_info_orig_arity(PredInfo), + ( if accu_has_heuristic(ModuleName, PredName, Arity) then + % Only do the transformation if the accumulator variable is + % *not* in a position where it will control the running time + % of the predicate. + accu_heuristic(ModuleName, PredName, Arity, Args, + PossibleDuringAssocVars), + set_of_var.member(PossibleDuringAssocVars, DuringAssocVar), + CurWarnings = [] + else + ProgContext = goal_info_get_context(GoalInfo), + CurWarnings = [accu_warn(ProgContext, PredId, BeforeAssocVar, + DuringAssocVar)] + ), + % Swap the arguments. + [A, B] = set_of_var.to_sorted_list(Vars), + map.from_assoc_list([A - B, B - A], Subst), + rename_some_vars_in_goal(Subst, Goal, SwappedGoal), + CSGoal = stored_goal(SwappedGoal, InstMap) + ), + + accu_process_assoc_set(ModuleInfo, GS, Ids, OutPrime, !Substs, + !VarSet, !VarTypes, CS0, Warnings0), + goal_store_det_insert(Id, CSGoal, CS0, CS), + Warnings = Warnings0 ++ CurWarnings. + +:- pred accu_has_heuristic(module_name::in, string::in, arity::in) is semidet. + +accu_has_heuristic(unqualified("list"), "append", 3). + + % heuristic returns the set of which head variables are important + % in the running time of the predicate. + % +:- pred accu_heuristic(module_name::in, string::in, arity::in, + list(prog_var)::in, set_of_progvar::out) is semidet. + +accu_heuristic(unqualified("list"), "append", 3, [_Typeinfo, A, _B, _C], + Set) :- + set_of_var.make_singleton(A, Set). + +%---------------------------------------------------------------------------% + + % For each member of the update set determine the substitutions needed + % (creating the accumulator variables when needed). + % Also associate with each Output variable which accumulator variable + % to get the result from. + % +:- pred accu_process_update_set(module_info::in, accu_goal_store::in, + list(accu_goal_id)::in, set_of_progvar::in, + accu_substs::in, accu_substs::out, + prog_varset::in, prog_varset::out, vartypes::in, vartypes::out, + list(prog_var)::out, list(prog_var)::out, list(pair(prog_var))::out) + is semidet. + +accu_process_update_set(_ModuleInfo, _GS, [], _OutPrime, !Substs, + !VarSet, !VarTypes, [], [], []). +accu_process_update_set(ModuleInfo, GS, [Id | Ids], OutPrime, !Substs, + !VarSet, !VarTypes, StateOutputVars, Accs, BasePairs) :- + !.Substs = accu_substs(AccVarSubst0, RecCallSubst0, AssocCallSubst, + UpdateSubst0), + lookup_call(GS, Id, stored_goal(Goal, _InstMap)), + + Goal = hlds_goal(plain_call(PredId, _, Args, _, _, _), _GoalInfo), + accu_is_update(ModuleInfo, PredId, Args, StateVars), + StateVars = state_update_vars(StateVarA, StateVarB), + + ( if set_of_var.member(OutPrime, StateVarA) then + StateInputVar = StateVarA, + StateOutputVar = StateVarB + else + StateInputVar = StateVarB, + StateOutputVar = StateVarA + ), + + create_new_var(StateInputVar, "Acc_", Acc0, !VarSet, !VarTypes), + create_new_var(StateOutputVar, "Acc_", Acc, !VarSet, !VarTypes), + + map.det_insert(StateInputVar, Acc0, UpdateSubst0, UpdateSubst1), + map.det_insert(StateOutputVar, Acc, UpdateSubst1, UpdateSubst), + map.det_insert(StateInputVar, StateOutputVar, RecCallSubst0, RecCallSubst), + map.det_insert(Acc, Acc0, AccVarSubst0, AccVarSubst), + !:Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst, + UpdateSubst), + + accu_process_update_set(ModuleInfo, GS, Ids, OutPrime, !Substs, + !VarSet, !VarTypes, StateOutputVars0, Accs0, BasePairs0), + + % Rather then concatenating to start of the list we concatenate to the end + % of the list. This allows the accumulator introduction to be applied + % as the heuristic will succeed (remember after transforming the two + % input variables will have their order swapped, so they must be in the + % inefficient order to start with) + + StateOutputVars = StateOutputVars0 ++ [StateOutputVar], + Accs = Accs0 ++ [Acc], + BasePairs = BasePairs0 ++ [StateOutputVar - Acc0]. + +%---------------------------------------------------------------------------% + + % divide_base_case(UpdateOut, Out, U, A, O) is true iff given the output + % variables which are instantiated by update goals, UpdateOut, and all + % the variables that need to be accumulated, Out, divide the base case up + % into three sets, those base case goals which initialize the variables + % used by update calls, U, those which initialize variables used by + % assoc calls, A, and the rest of the goals, O. Note that the sets + % are not necessarily disjoint, as the result of a goal may be used + % to initialize a variable in both U and A, so both U and A will contain + % the same goal_id. + % +:- pred accu_divide_base_case(module_info::in, vartypes::in, + accu_goal_store::in, list(prog_var)::in, list(prog_var)::in, + set(accu_goal_id)::out, set(accu_goal_id)::out, set(accu_goal_id)::out) + is det. + +accu_divide_base_case(ModuleInfo, VarTypes, C, UpdateOut, Out, + UpdateBase, AssocBase, OtherBase) :- + list.delete_elems(Out, UpdateOut, AssocOut), + + list.map(accu_related(ModuleInfo, VarTypes, C), UpdateOut, UpdateBaseList), + list.map(accu_related(ModuleInfo, VarTypes, C), AssocOut, AssocBaseList), + UpdateBase = set.power_union(set.list_to_set(UpdateBaseList)), + AssocBase = set.power_union(set.list_to_set(AssocBaseList)), + + Set = base_case_ids_set(C) `difference` (UpdateBase `union` AssocBase), + set.to_sorted_list(Set, List), + + list.map( + ( pred(GoalId::in, Ancestors::out) is det :- + goal_store_all_ancestors(C, GoalId, VarTypes, + ModuleInfo, no, Ancestors) + ), List, OtherBaseList), + + OtherBase = set.list_to_set(List) `union` + (base_case_ids_set(C) `intersect` + set.power_union(set.list_to_set(OtherBaseList))). + + % accu_related(ModuleInfo, VarTypes, GoalStore, Var, Related): + % + % From GoalStore, return all the goal_ids, Related, which are needed + % to initialize Var. + % +:- pred accu_related(module_info::in, vartypes::in, accu_goal_store::in, + prog_var::in, set(accu_goal_id)::out) is det. + +accu_related(ModuleInfo, VarTypes, GoalStore, Var, Related) :- + solutions.solutions( + ( pred(Key::out) is nondet :- + goal_store_member(GoalStore, Key, stored_goal(Goal, InstMap0)), + Key = accu_goal_id(accu_base, _), + Goal = hlds_goal(_GoalExpr, GoalInfo), + InstMapDelta = goal_info_get_instmap_delta(GoalInfo), + apply_instmap_delta(InstMapDelta, InstMap0, InstMap), + instmap_changed_vars(ModuleInfo, VarTypes, + InstMap0, InstMap, ChangedVars), + set_of_var.is_singleton(ChangedVars, Var) + ), Ids), + ( + Ids = [], + unexpected($pred, "no Id") + ; + Ids = [Id], + goal_store_all_ancestors(GoalStore, Id, VarTypes, ModuleInfo, no, + Ancestors), + list.filter((pred(accu_goal_id(accu_base, _)::in) is semidet), + set.to_sorted_list(set.insert(Ancestors, Id)), RelatedList), + Related = set.list_to_set(RelatedList) + ; + Ids = [_, _ | _], + unexpected($pred, "more than one Id") + ). + +%---------------------------------------------------------------------------% + +:- inst stored_goal_plain_call for goal_store.stored_goal/0 + ---> stored_goal(goal_plain_call, ground). + + % Do a goal_store_lookup where the result is known to be a call. + % +:- pred lookup_call(accu_goal_store::in, accu_goal_id::in, + stored_goal::out(stored_goal_plain_call)) is det. + +lookup_call(GoalStore, Id, stored_goal(Call, InstMap)) :- + goal_store_lookup(GoalStore, Id, stored_goal(Goal, InstMap)), + ( if + Goal = hlds_goal(GoalExpr, GoalInfo), + GoalExpr = plain_call(_, _, _, _, _, _) + then + Call = hlds_goal(GoalExpr, GoalInfo) + else + unexpected($pred, "not a call") + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % accu_stage3 creates the accumulator version of the predicate using + % the substitutions determined in stage2. It also redefines the + % original procedure to call the accumulator version of the procedure. + % +:- pred accu_stage3(accu_goal_id::in, list(prog_var)::in, prog_varset::in, + vartypes::in, accu_goal_store::in, accu_goal_store::in, + accu_substs::in, accu_subst::in, accu_subst::in, + accu_base::in, list(pair(prog_var))::in, accu_sets::in, + list(prog_var)::in, top_level::in, pred_id::in, pred_info::in, + proc_info::in, proc_info::out, module_info::in, module_info::out) is det. + +accu_stage3(RecCallId, Accs, VarSet, VarTypes, C, CS, Substs, + HeadToCallSubst, CallToHeadSubst, BaseCase, BasePairs, Sets, Out, + TopLevel, OrigPredId, OrigPredInfo, !OrigProcInfo, !ModuleInfo) :- + acc_proc_info(Accs, VarSet, VarTypes, Substs, !.OrigProcInfo, + AccTypes, AccProcInfo), + acc_pred_info(AccTypes, Out, AccProcInfo, OrigPredId, OrigPredInfo, + AccProcId, AccPredInfo), + AccName = unqualified(pred_info_name(AccPredInfo)), + + module_info_get_predicate_table(!.ModuleInfo, PredTable0), + predicate_table_insert(AccPredInfo, AccPredId, PredTable0, PredTable), + module_info_set_predicate_table(PredTable, !ModuleInfo), + accu_create_goal(RecCallId, Accs, AccPredId, AccProcId, AccName, Substs, + HeadToCallSubst, CallToHeadSubst, BaseCase, BasePairs, Sets, C, CS, + OrigBaseGoal, OrigRecGoal, AccBaseGoal, AccRecGoal), + + proc_info_get_goal(!.OrigProcInfo, OrigGoal0), + accu_top_level(TopLevel, OrigGoal0, OrigBaseGoal, OrigRecGoal, + AccBaseGoal, AccRecGoal, OrigGoal, AccGoal), + + proc_info_set_goal(OrigGoal, !OrigProcInfo), + proc_info_set_varset(VarSet, !OrigProcInfo), + proc_info_set_vartypes(VarTypes, !OrigProcInfo), + + requantify_proc_general(ordinary_nonlocals_no_lambda, !OrigProcInfo), + update_accumulator_pred(AccPredId, AccProcId, AccGoal, !ModuleInfo). + +%---------------------------------------------------------------------------% + + % Construct a proc_info for the introduced predicate. + % +:- pred acc_proc_info(list(prog_var)::in, prog_varset::in, vartypes::in, + accu_substs::in, proc_info::in, list(mer_type)::out, proc_info::out) + is det. + +acc_proc_info(Accs0, VarSet, VarTypes, Substs, OrigProcInfo, + AccTypes, AccProcInfo) :- + % ProcInfo Stuff that must change. + proc_info_get_headvars(OrigProcInfo, HeadVars0), + proc_info_get_argmodes(OrigProcInfo, HeadModes0), + + proc_info_get_inst_varset(OrigProcInfo, InstVarSet), + proc_info_get_inferred_determinism(OrigProcInfo, Detism), + proc_info_get_goal(OrigProcInfo, Goal), + proc_info_get_context(OrigProcInfo, Context), + proc_info_get_rtti_varmaps(OrigProcInfo, RttiVarMaps), + proc_info_get_is_address_taken(OrigProcInfo, IsAddressTaken), + proc_info_get_has_parallel_conj(OrigProcInfo, HasParallelConj), + proc_info_get_var_name_remap(OrigProcInfo, VarNameRemap), + + Substs = accu_substs(AccVarSubst, _RecCallSubst, _AssocCallSubst, + _UpdateSubst), + list.map(map.lookup(AccVarSubst), Accs0, Accs), + + % We place the extra accumulator variables at the start, because placing + % them at the end breaks the convention that the last variable of a + % function is the output variable. + HeadVars = Accs ++ HeadVars0, + + % XXX we don't want to use the inst of the var as it can be more specific + % than it should be. ie int_const(1) when it should be any integer. + % However this will no longer handle partially instantiated data + % structures. + Inst = ground(shared, none_or_default_func), + inst_lists_to_mode_list([Inst], [Inst], Mode), + list.duplicate(list.length(Accs), list.det_head(Mode), AccModes), + HeadModes = AccModes ++ HeadModes0, + + lookup_var_types(VarTypes, Accs, AccTypes), + + SeqNum = item_no_seq_num, + proc_info_create(Context, SeqNum, VarSet, VarTypes, HeadVars, + InstVarSet, HeadModes, detism_decl_none, Detism, Goal, RttiVarMaps, + IsAddressTaken, HasParallelConj, VarNameRemap, AccProcInfo). + +%---------------------------------------------------------------------------% + + % Construct the pred_info for the introduced predicate. + % +:- pred acc_pred_info(list(mer_type)::in, list(prog_var)::in, proc_info::in, + pred_id::in, pred_info::in, proc_id::out, pred_info::out) is det. + +acc_pred_info(NewTypes, OutVars, NewProcInfo, OrigPredId, OrigPredInfo, + NewProcId, NewPredInfo) :- + % PredInfo stuff that must change. + pred_info_get_arg_types(OrigPredInfo, TypeVarSet, ExistQVars, Types0), + + ModuleName = pred_info_module(OrigPredInfo), + Name = pred_info_name(OrigPredInfo), + PredOrFunc = pred_info_is_pred_or_func(OrigPredInfo), + pred_info_get_context(OrigPredInfo, PredContext), + pred_info_get_markers(OrigPredInfo, Markers), + pred_info_get_class_context(OrigPredInfo, ClassContext), + pred_info_get_origin(OrigPredInfo, OldOrigin), + pred_info_get_var_name_remap(OrigPredInfo, VarNameRemap), + + set.init(Assertions), + + proc_info_get_context(NewProcInfo, Context), + term.context_line(Context, Line), + Counter = 0, + + Types = NewTypes ++ Types0, + + make_pred_name_with_context(ModuleName, "AccFrom", PredOrFunc, Name, + Line, Counter, SymName), + + OutVarNums = list.map(term.var_to_int, OutVars), + Origin = origin_transformed(transform_accumulator(OutVarNums), + OldOrigin, OrigPredId), + GoalType = goal_not_for_promise(np_goal_type_none), + pred_info_create(ModuleName, SymName, PredOrFunc, PredContext, Origin, + pred_status(status_local), Markers, Types, TypeVarSet, + ExistQVars, ClassContext, Assertions, VarNameRemap, GoalType, + NewProcInfo, NewProcId, NewPredInfo). + +%---------------------------------------------------------------------------% + + % create_goal creates the new base and recursive case of the + % original procedure (OrigBaseGoal and OrigRecGoal) and the base + % and recursive cases of accumulator version (AccBaseGoal and + % AccRecGoal). + % +:- pred accu_create_goal(accu_goal_id::in, list(prog_var)::in, + pred_id::in, proc_id::in, sym_name::in, accu_substs::in, + accu_subst::in, accu_subst::in, accu_base::in, + list(pair(prog_var))::in, accu_sets::in, + accu_goal_store::in, accu_goal_store::in, + hlds_goal::out, hlds_goal::out, hlds_goal::out, hlds_goal::out) is det. + +accu_create_goal(RecCallId, Accs, AccPredId, AccProcId, AccName, Substs, + HeadToCallSubst, CallToHeadSubst, BaseIds, BasePairs, + Sets, C, CS, OrigBaseGoal, OrigRecGoal, AccBaseGoal, AccRecGoal) :- + lookup_call(C, RecCallId, stored_goal(OrigCall, _InstMap)), + Call = create_acc_call(OrigCall, Accs, AccPredId, AccProcId, AccName), + create_orig_goal(Call, Substs, HeadToCallSubst, CallToHeadSubst, + BaseIds, Sets, C, OrigBaseGoal, OrigRecGoal), + create_acc_goal(Call, Substs, HeadToCallSubst, BaseIds, BasePairs, + Sets, C, CS, AccBaseGoal, AccRecGoal). + + % create_acc_call takes the original call and generates a call to the + % accumulator version of the call, which can have the substitutions + % applied to it easily. + % +:- func create_acc_call(hlds_goal::in(goal_plain_call), list(prog_var)::in, + pred_id::in, proc_id::in, sym_name::in) = (hlds_goal::out(goal_plain_call)) + is det. + +create_acc_call(OrigCall, Accs, AccPredId, AccProcId, AccName) = Call :- + OrigCall = hlds_goal(OrigCallExpr, GoalInfo), + OrigCallExpr = plain_call(_PredId, _ProcId, Args, Builtin, Context, _Name), + CallExpr = plain_call(AccPredId, AccProcId, Accs ++ Args, Builtin, + Context, AccName), + Call = hlds_goal(CallExpr, GoalInfo). + + % Create the goals which are to replace the original predicate. + % +:- pred create_orig_goal(hlds_goal::in, accu_substs::in, + accu_subst::in, accu_subst::in, accu_base::in, accu_sets::in, + accu_goal_store::in, hlds_goal::out, hlds_goal::out) is det. + +create_orig_goal(Call, Substs, HeadToCallSubst, CallToHeadSubst, + BaseIds, Sets, C, OrigBaseGoal, OrigRecGoal) :- + Substs = accu_substs(_AccVarSubst, _RecCallSubst, _AssocCallSubst, + UpdateSubst), + + BaseIds = accu_base(UpdateBase, _AssocBase, _OtherBase), + Before = Sets ^ as_before, + Update = Sets ^ as_update, + + U = create_new_orig_recursive_goals(UpdateBase, Update, + HeadToCallSubst, UpdateSubst, C), + + rename_some_vars_in_goal(CallToHeadSubst, Call, BaseCall), + Cbefore = accu_goal_list(set.to_sorted_list(Before), C), + Uupdate = accu_goal_list(set.to_sorted_list(UpdateBase) ++ + set.to_sorted_list(Update), U), + Cbase = accu_goal_list(base_case_ids(C), C), + calculate_goal_info(conj(plain_conj, Cbefore ++ Uupdate ++ [BaseCall]), + OrigRecGoal), + calculate_goal_info(conj(plain_conj, Cbase), OrigBaseGoal). + + % Create the goals which are to go in the new accumulator version + % of the predicate. + % +:- pred create_acc_goal(hlds_goal::in, accu_substs::in, accu_subst::in, + accu_base::in, list(pair(prog_var))::in, accu_sets::in, + accu_goal_store::in, accu_goal_store::in, + hlds_goal::out, hlds_goal::out) is det. + +create_acc_goal(Call, Substs, HeadToCallSubst, BaseIds, BasePairs, Sets, + C, CS, AccBaseGoal, AccRecGoal) :- + Substs = accu_substs(AccVarSubst, RecCallSubst, AssocCallSubst, + UpdateSubst), + + BaseIds = accu_base(_UpdateBase, AssocBase, OtherBase), + Sets = accu_sets(Before, Assoc, ConstructAssoc, Construct, Update, + _Reject), + + rename_some_vars_in_goal(RecCallSubst, Call, RecCall), + + Cbefore = accu_goal_list(set.to_sorted_list(Before), C), + + % Create the goals which will be used in the new recursive case. + R = create_new_recursive_goals(Assoc, Construct `union` ConstructAssoc, + Update, AssocCallSubst, AccVarSubst, UpdateSubst, C, CS), + + Rassoc = accu_goal_list(set.to_sorted_list(Assoc), R), + Rupdate = accu_goal_list(set.to_sorted_list(Update), R), + Rconstruct = accu_goal_list(set.to_sorted_list(Construct `union` + ConstructAssoc), R), + + % Create the goals which will be used in the new base case. + B = create_new_base_goals(Assoc `union` Construct `union` + ConstructAssoc, C, AccVarSubst, HeadToCallSubst), + Bafter = set.to_sorted_list(Assoc `union` + Construct `union` ConstructAssoc), + + BaseCase = accu_goal_list(set.to_sorted_list(AssocBase `union` OtherBase) + ++ Bafter, B), + + list.map(acc_unification, BasePairs, UpdateBase), + + calculate_goal_info(conj(plain_conj, Cbefore ++ Rassoc ++ Rupdate + ++ [RecCall] ++ Rconstruct), AccRecGoal), + calculate_goal_info(conj(plain_conj, UpdateBase ++ BaseCase), AccBaseGoal). + + % Create the U set of goals (those that will be used in the original + % recursive case) by renaming all the goals which are used to initialize + % the update state variable using the head_to_call followed by the + % update_subst, and rename all the update goals using the update_subst. + % +:- func create_new_orig_recursive_goals(set(accu_goal_id), set(accu_goal_id), + accu_subst, accu_subst, accu_goal_store) = accu_goal_store. + +create_new_orig_recursive_goals(UpdateBase, Update, HeadToCallSubst, + UpdateSubst, C) + = accu_rename(set.to_sorted_list(Update), UpdateSubst, C, Ubase) :- + Ubase = accu_rename(set.to_sorted_list(UpdateBase), + chain_subst(HeadToCallSubst, UpdateSubst), C, goal_store_init). + + % Create the R set of goals (those that will be used in the new + % recursive case) by renaming all the members of assoc in CS + % using assoc_call_subst and all the members of (construct U + % construct_assoc) in C with acc_var_subst. + % +:- func create_new_recursive_goals(set(accu_goal_id), set(accu_goal_id), + set(accu_goal_id), accu_subst, accu_subst, accu_subst, + accu_goal_store, accu_goal_store) = accu_goal_store. + +create_new_recursive_goals(Assoc, Constructs, Update, + AssocCallSubst, AccVarSubst, UpdateSubst, C, CS) + = accu_rename(set.to_sorted_list(Constructs), AccVarSubst, C, RBase) :- + RBase0 = accu_rename(set.to_sorted_list(Assoc), AssocCallSubst, CS, + goal_store_init), + RBase = accu_rename(set.to_sorted_list(Update), UpdateSubst, C, RBase0). + + % Create the B set of goals (those that will be used in the new base case) + % by renaming all the base case goals of C with head_to_call and all the + % members of (assoc U construct U construct_assoc) of C with acc_var_subst. + % +:- func create_new_base_goals(set(accu_goal_id), accu_goal_store, + accu_subst, accu_subst) = accu_goal_store. + +create_new_base_goals(Ids, C, AccVarSubst, HeadToCallSubst) + = accu_rename(set.to_sorted_list(Ids), AccVarSubst, C, Bbase) :- + Bbase = accu_rename(base_case_ids(C), HeadToCallSubst, C, goal_store_init). + + % acc_unification(O-A, G): + % + % is true if G represents the assignment unification Out = Acc. + % +:- pred acc_unification(pair(prog_var)::in, hlds_goal::out) is det. + +acc_unification(Out - Acc, Goal) :- + UnifyMode = unify_modes_li_lf_ri_rf(free, ground_inst, + ground_inst, ground_inst), + Context = unify_context(umc_explicit, []), + Expr = unify(Out, rhs_var(Acc), UnifyMode, assign(Out,Acc), Context), + set_of_var.list_to_set([Out, Acc], NonLocalVars), + InstMapDelta = instmap_delta_bind_var(Out), + goal_info_init(NonLocalVars, InstMapDelta, detism_det, purity_pure, Info), + Goal = hlds_goal(Expr, Info). + +%---------------------------------------------------------------------------% + + % Given the top level structure of the goal create new version + % with new base and recursive cases plugged in. + % +:- pred accu_top_level(top_level::in, hlds_goal::in, + hlds_goal::in, hlds_goal::in, hlds_goal::in, + hlds_goal::in, hlds_goal::out, hlds_goal::out) is det. + +accu_top_level(TopLevel, Goal, OrigBaseGoal, OrigRecGoal, + NewBaseGoal, NewRecGoal, OrigGoal, NewGoal) :- + ( + TopLevel = switch_base_rec, + ( if + Goal = hlds_goal(switch(Var, CanFail, Cases0), GoalInfo), + Cases0 = [case(IdA, [], _), case(IdB, [], _)] + then + OrigCases = [case(IdA, [], OrigBaseGoal), + case(IdB, [], OrigRecGoal)], + OrigGoal = hlds_goal(switch(Var, CanFail, OrigCases), GoalInfo), + + NewCases = [case(IdA, [], NewBaseGoal), case(IdB, [], NewRecGoal)], + NewGoal = hlds_goal(switch(Var, CanFail, NewCases), GoalInfo) + else + unexpected($pred, "not the correct top level") + ) + ; + TopLevel = switch_rec_base, + ( if + Goal = hlds_goal(switch(Var, CanFail, Cases0), GoalInfo), + Cases0 = [case(IdA, [], _), case(IdB, [], _)] + then + OrigCases = [case(IdA, [], OrigRecGoal), + case(IdB, [], OrigBaseGoal)], + OrigGoal = hlds_goal(switch(Var, CanFail, OrigCases), GoalInfo), + + NewCases = [case(IdA, [], NewRecGoal), case(IdB, [], NewBaseGoal)], + NewGoal = hlds_goal(switch(Var, CanFail, NewCases), GoalInfo) + else + unexpected($pred, "not the correct top level") + ) + ; + TopLevel = disj_base_rec, + ( if + Goal = hlds_goal(disj(Goals), GoalInfo), + Goals = [_, _] + then + OrigGoals = [OrigBaseGoal, OrigRecGoal], + OrigGoal = hlds_goal(disj(OrigGoals), GoalInfo), + + NewGoals = [NewBaseGoal, NewRecGoal], + NewGoal = hlds_goal(disj(NewGoals), GoalInfo) + else + unexpected($pred, "not the correct top level") + ) + ; + TopLevel = disj_rec_base, + ( if + Goal = hlds_goal(disj(Goals), GoalInfo), + Goals = [_, _] + then + OrigGoals = [OrigRecGoal, OrigBaseGoal], + OrigGoal = hlds_goal(disj(OrigGoals), GoalInfo), + + NewGoals = [NewRecGoal, NewBaseGoal], + NewGoal = hlds_goal(disj(NewGoals), GoalInfo) + else + unexpected($pred, "not the correct top level") + ) + ; + TopLevel = ite_base_rec, + ( if Goal = hlds_goal(if_then_else(Vars, Cond, _, _), GoalInfo) then + OrigGoal = hlds_goal(if_then_else(Vars, Cond, + OrigBaseGoal, OrigRecGoal), GoalInfo), + NewGoal = hlds_goal(if_then_else(Vars, Cond, + NewBaseGoal, NewRecGoal), GoalInfo) + else + unexpected($pred, "not the correct top level") + ) + ; + TopLevel = ite_rec_base, + ( if Goal = hlds_goal(if_then_else(Vars, Cond, _, _), GoalInfo) then + OrigGoal = hlds_goal(if_then_else(Vars, Cond, + OrigRecGoal, OrigBaseGoal), GoalInfo), + NewGoal = hlds_goal(if_then_else(Vars, Cond, + NewRecGoal, NewBaseGoal), GoalInfo) + else + unexpected($pred, "not the correct top level") + ) + ). + +%---------------------------------------------------------------------------% + + % Place the accumulator version of the predicate in the HLDS. + % +:- pred update_accumulator_pred(pred_id::in, proc_id::in, + hlds_goal::in, module_info::in, module_info::out) is det. + +update_accumulator_pred(NewPredId, NewProcId, AccGoal, !ModuleInfo) :- + module_info_pred_proc_info(!.ModuleInfo, NewPredId, NewProcId, + PredInfo, ProcInfo0), + proc_info_set_goal(AccGoal, ProcInfo0, ProcInfo1), + requantify_proc_general(ordinary_nonlocals_no_lambda, ProcInfo1, ProcInfo), + module_info_set_pred_proc_info(NewPredId, NewProcId, + PredInfo, ProcInfo, !ModuleInfo). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + + % accu_rename(Ids, Subst, From, Initial): + % + % Return a goal_store, Final, which is the result of looking up each + % member of set of goal_ids, Ids, in the goal_store, From, applying + % the substitution and then storing the goal into the goal_store, Initial. + % +:- func accu_rename(list(accu_goal_id), accu_subst, + accu_goal_store, accu_goal_store) = accu_goal_store. + +accu_rename(Ids, Subst, From, Initial) = Final :- + list.foldl( + ( pred(Id::in, GS0::in, GS::out) is det :- + goal_store_lookup(From, Id, stored_goal(Goal0, InstMap)), + rename_some_vars_in_goal(Subst, Goal0, Goal), + goal_store_det_insert(Id, stored_goal(Goal, InstMap), GS0, GS) + ), Ids, Initial, Final). + + % Return all the goal_ids which belong in the base case. + % +:- func base_case_ids(accu_goal_store) = list(accu_goal_id). + +base_case_ids(GS) = Base :- + solutions.solutions( + ( pred(Key::out) is nondet :- + goal_store_member(GS, Key, _Goal), + Key = accu_goal_id(accu_base, _) + ), Base). + +:- func base_case_ids_set(accu_goal_store) = set(accu_goal_id). + +base_case_ids_set(GS) = set.list_to_set(base_case_ids(GS)). + + % Given a list of goal_ids, return the list of hlds_goals from + % the goal_store. + % +:- func accu_goal_list(list(accu_goal_id), accu_goal_store) = list(hlds_goal). + +accu_goal_list(Ids, GS) = Goals :- + list.map( + ( pred(Key::in, G::out) is det :- + goal_store_lookup(GS, Key, stored_goal(G, _)) + ), Ids, Goals). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- pred calculate_goal_info(hlds_goal_expr::in, hlds_goal::out) is det. + +calculate_goal_info(GoalExpr, hlds_goal(GoalExpr, GoalInfo)) :- + ( if GoalExpr = conj(plain_conj, GoalList) then + goal_list_nonlocals(GoalList, NonLocals), + goal_list_instmap_delta(GoalList, InstMapDelta), + goal_list_determinism(GoalList, Detism), + + goal_info_init(NonLocals, InstMapDelta, Detism, purity_pure, GoalInfo) + else + unexpected($pred, "not a conj") + ). + +%---------------------------------------------------------------------------% +%---------------------------------------------------------------------------% + +:- func chain_subst(accu_subst, accu_subst) = accu_subst. + +chain_subst(AtoB, BtoC) = AtoC :- + map.keys(AtoB, Keys), + chain_subst_2(Keys, AtoB, BtoC, AtoC). + +:- pred chain_subst_2(list(A)::in, map(A, B)::in, map(B, C)::in, + map(A, C)::out) is det. + +chain_subst_2([], _, _, AtoC) :- + map.init(AtoC). +chain_subst_2([A | As], AtoB, BtoC, AtoC) :- + chain_subst_2(As, AtoB, BtoC, AtoC0), + map.lookup(AtoB, A, B), + ( if map.search(BtoC, B, C) then + map.det_insert(A, C, AtoC0, AtoC) + else + AtoC = AtoC0 + ). + +%---------------------------------------------------------------------------% +:- end_module transform_hlds.accumulator. +%---------------------------------------------------------------------------% -- 2.31.1 ^ permalink raw reply related [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-01 2:38 ` bug#47408: Etags support for Mercury [v0.5] fabrice nicol @ 2021-06-06 9:48 ` Eli Zaretskii 2021-06-06 13:34 ` fabrice nicol 0 siblings, 1 reply; 27+ messages in thread From: Eli Zaretskii @ 2021-06-06 9:48 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408-done > From: fabrice nicol <fabrnicol@gmail.com> > Cc: 47408@debbugs.gnu.org > Date: Tue, 1 Jun 2021 04:38:56 +0200 > > Mercury-specific declarations will be tagged by default. Thanks, I installed the changes. I see that there's no Mercury support for ctags (the 'ctags' output of the test suite remained without change) -- is that intentional? ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-06 9:48 ` Eli Zaretskii @ 2021-06-06 13:34 ` fabrice nicol 2021-06-06 18:18 ` Francesco Potortì 0 siblings, 1 reply; 27+ messages in thread From: fabrice nicol @ 2021-06-06 13:34 UTC (permalink / raw) To: Eli Zaretskii; +Cc: 47408-done Yes, unless I am mistaken, ctags has no practical use outside of the C-family language domain. Le 06/06/2021 à 11:48, Eli Zaretskii a écrit : >> From: fabrice nicol <fabrnicol@gmail.com> >> Cc: 47408@debbugs.gnu.org >> Date: Tue, 1 Jun 2021 04:38:56 +0200 >> >> Mercury-specific declarations will be tagged by default. > Thanks, I installed the changes. > > I see that there's no Mercury support for ctags (the 'ctags' output of > the test suite remained without change) -- is that intentional? ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-06 13:34 ` fabrice nicol @ 2021-06-06 18:18 ` Francesco Potortì 2021-06-06 20:49 ` fabrice nicol 0 siblings, 1 reply; 27+ messages in thread From: Francesco Potortì @ 2021-06-06 18:18 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408-done Eli Zaretskii: >> I see that there's no Mercury support for ctags (the 'ctags' output of >> the test suite remained without change) -- is that intentional? Fabrice Nicol: >Yes, unless I am mistaken, ctags has no practical use outside of the >C-family language domain. That's difficult to tell for me. However, etags provides ctags support for all languages it knows about. I may be missing something, but I think Mercury would be the first exception. If that's the case, maybe it would be worth adding a comment telling so. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-06 18:18 ` Francesco Potortì @ 2021-06-06 20:49 ` fabrice nicol 2021-06-06 21:04 ` Francesco Potortì 2021-06-07 12:13 ` Eli Zaretskii 0 siblings, 2 replies; 27+ messages in thread From: fabrice nicol @ 2021-06-06 20:49 UTC (permalink / raw) To: Francesco Potortì; +Cc: 47408-done > Yes, unless I am mistaken, ctags has no practical use outside of the >> C-family language domain. > That's difficult to tell for me. However, etags provides ctags support > for all languages it knows about. I may be missing something, but I > think Mercury would be the first exception. If that's the case, maybe > it would be worth adding a comment telling so. ctags only differs from etags by the fact that its output is Vim-compatible. But it so happens that Mercury has superior in-built support for Vim tagging (the core team use Vim). So ctags would not actually be used by users with Vim-compatibility requirements, they would just use Mercury tagging on Vim. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-06 20:49 ` fabrice nicol @ 2021-06-06 21:04 ` Francesco Potortì 2021-06-07 12:13 ` Eli Zaretskii 1 sibling, 0 replies; 27+ messages in thread From: Francesco Potortì @ 2021-06-06 21:04 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408-done >> Yes, unless I am mistaken, ctags has no practical use outside of the >>> C-family language domain. >> That's difficult to tell for me. However, etags provides ctags support >> for all languages it knows about. I may be missing something, but I >> think Mercury would be the first exception. If that's the case, maybe >> it would be worth adding a comment telling so. > >ctags only differs from etags by the fact that its output is >Vim-compatible. But it so happens that Mercury has superior in-built >support for Vim tagging (the core team use Vim). So ctags would not >actually be used by users with Vim-compatibility requirements, they >would just use Mercury tagging on Vim. Maybe adding this info in a comment inside etags' code would be useful for future maintainers. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-06 20:49 ` fabrice nicol 2021-06-06 21:04 ` Francesco Potortì @ 2021-06-07 12:13 ` Eli Zaretskii 2021-06-08 0:38 ` Fabrice Nicol 2021-06-08 10:53 ` Francesco Potortì 1 sibling, 2 replies; 27+ messages in thread From: Eli Zaretskii @ 2021-06-07 12:13 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 > Cc: 47408-done@debbugs.gnu.org, Eli Zaretskii <eliz@gnu.org> > From: fabrice nicol <fabrnicol@gmail.com> > Date: Sun, 6 Jun 2021 22:49:19 +0200 > > > That's difficult to tell for me. However, etags provides ctags support > > for all languages it knows about. I may be missing something, but I > > think Mercury would be the first exception. If that's the case, maybe > > it would be worth adding a comment telling so. > > ctags only differs from etags by the fact that its output is > Vim-compatible. But it so happens that Mercury has superior in-built > support for Vim tagging (the core team use Vim). So ctags would not > actually be used by users with Vim-compatibility requirements, they > would just use Mercury tagging on Vim. What do we lose if we make Mercury support active in ctags mode? Do we even need to add any code for that? ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-07 12:13 ` Eli Zaretskii @ 2021-06-08 0:38 ` Fabrice Nicol 2021-06-08 10:53 ` Francesco Potortì 1 sibling, 0 replies; 27+ messages in thread From: Fabrice Nicol @ 2021-06-08 0:38 UTC (permalink / raw) To: Eli Zaretskii; +Cc: 47408 [-- Attachment #1: Type: text/plain, Size: 1171 bytes --] There is something to be fixed if this is the expected output, as ctags invocation dose not work for Mercury files. I have not looked into the issue yet but the fix should be quite small. Le mar. 8 juin 2021 à 2:05 AM, Eli Zaretskii <eliz@gnu.org> a écrit : > > Cc: 47408-done@debbugs.gnu.org, Eli Zaretskii <eliz@gnu.org> > > From: fabrice nicol <fabrnicol@gmail.com> > > Date: Sun, 6 Jun 2021 22:49:19 +0200 > > > > > That's difficult to tell for me. However, etags provides ctags support > > > for all languages it knows about. I may be missing something, but I > > > think Mercury would be the first exception. If that's the case, maybe > > > it would be worth adding a comment telling so. > > > > ctags only differs from etags by the fact that its output is > > Vim-compatible. But it so happens that Mercury has superior in-built > > support for Vim tagging (the core team use Vim). So ctags would not > > actually be used by users with Vim-compatibility requirements, they > > would just use Mercury tagging on Vim. > > What do we lose if we make Mercury support active in ctags mode? Do > we even need to add any code for that? > [-- Attachment #2: Type: text/html, Size: 1803 bytes --] ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-07 12:13 ` Eli Zaretskii 2021-06-08 0:38 ` Fabrice Nicol @ 2021-06-08 10:53 ` Francesco Potortì 2021-06-08 11:47 ` Eli Zaretskii 1 sibling, 1 reply; 27+ messages in thread From: Francesco Potortì @ 2021-06-08 10:53 UTC (permalink / raw) To: Eli Zaretskii; +Cc: 47408, fabrice nicol Eli Zaretskii: >>>> I see that there's no Mercury support for ctags (the 'ctags' output of >>>> the test suite remained without change) -- is that intentional? Fabrice Nicol: >> ctags only differs from etags by the fact that its output is >> Vim-compatible. But it so happens that Mercury has superior in-built >> support for Vim tagging (the core team use Vim). So ctags would not >> actually be used by users with Vim-compatibility requirements, they >> would just use Mercury tagging on Vim. Eli Zaretski: > What do we lose if we make Mercury support active in ctags mode? Do > we even need to add any code for that? I just looked at the code. Unless I am grossly mistaken, nothing is needed to get ctags output. You just call the program as ctags and that's it. So there is no reason to prevent ctags help from mentioning Mercurial. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-08 10:53 ` Francesco Potortì @ 2021-06-08 11:47 ` Eli Zaretskii 2021-06-08 12:47 ` Francesco Potortì 0 siblings, 1 reply; 27+ messages in thread From: Eli Zaretskii @ 2021-06-08 11:47 UTC (permalink / raw) To: Francesco Potortì; +Cc: 47408, fabrnicol > From: Francesco Potortì <pot@gnu.org> > Date: Tue, 08 Jun 2021 12:53:23 +0200 > Cc: 47408@debbugs.gnu.org, > fabrice nicol <fabrnicol@gmail.com> > > > What do we lose if we make Mercury support active in ctags mode? Do > > we even need to add any code for that? > > I just looked at the code. Unless I am grossly mistaken, nothing is > needed to get ctags output. You just call the program as ctags and > that's it. So there is no reason to prevent ctags help from mentioning > Mercurial. Then how come, when I run the etags test suite (test/manual/etags/), I get no change in the produced CTAGS file wrt CTAGS.good? That .good file is from before we added the Mercury source to the suite. What am I missing? ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-08 11:47 ` Eli Zaretskii @ 2021-06-08 12:47 ` Francesco Potortì 2021-06-10 13:59 ` Eli Zaretskii 0 siblings, 1 reply; 27+ messages in thread From: Francesco Potortì @ 2021-06-08 12:47 UTC (permalink / raw) To: Eli Zaretskii; +Cc: fabrnicol, 47408 >> From: Francesco Potortì <pot@gnu.org> >> Date: Tue, 08 Jun 2021 12:53:23 +0200 >> Cc: 47408@debbugs.gnu.org, >> fabrice nicol <fabrnicol@gmail.com> >> >> > What do we lose if we make Mercury support active in ctags mode? Do >> > we even need to add any code for that? >> >> I just looked at the code. Unless I am grossly mistaken, nothing is >> needed to get ctags output. You just call the program as ctags and >> that's it. So there is no reason to prevent ctags help from mentioning >> Mercurial. > >Then how come, when I run the etags test suite (test/manual/etags/), I >get no change in the produced CTAGS file wrt CTAGS.good? That .good >file is from before we added the Mercury source to the suite. What am >I missing? Sorry, don't know :( Looked again, but then I'd need to debug it to know... ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-08 12:47 ` Francesco Potortì @ 2021-06-10 13:59 ` Eli Zaretskii 2021-06-10 16:52 ` fabrice nicol 0 siblings, 1 reply; 27+ messages in thread From: Eli Zaretskii @ 2021-06-10 13:59 UTC (permalink / raw) To: Francesco Potortì; +Cc: fabrnicol, 47408 > From: Francesco Potortì <pot@gnu.org> > Date: Tue, 08 Jun 2021 14:47:13 +0200 > Cc: fabrnicol@gmail.com, > 47408@debbugs.gnu.org > > >> I just looked at the code. Unless I am grossly mistaken, nothing is > >> needed to get ctags output. You just call the program as ctags and > >> that's it. So there is no reason to prevent ctags help from mentioning > >> Mercurial. > > > >Then how come, when I run the etags test suite (test/manual/etags/), I > >get no change in the produced CTAGS file wrt CTAGS.good? That .good > >file is from before we added the Mercury source to the suite. What am > >I missing? > > Sorry, don't know :( Looked again, but then I'd need to debug it to know... I found the reason: make_tag was called incorrectly from mercury_pr. This should be fixed now. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-10 13:59 ` Eli Zaretskii @ 2021-06-10 16:52 ` fabrice nicol 2021-06-10 17:05 ` Francesco Potortì 2021-06-10 17:20 ` Eli Zaretskii 0 siblings, 2 replies; 27+ messages in thread From: fabrice nicol @ 2021-06-10 16:52 UTC (permalink / raw) To: Eli Zaretskii, Francesco Potortì; +Cc: 47408 [-- Attachment #1: Type: text/plain, Size: 1957 bytes --] Eli, your latest fix for Mercury 'etags' support has introduced a regression for existentially quantified predicates. These predicates have the following (somewhat simplified) syntax (in extended regexp form, \s for white space): :-[:blank:]+some[:blank:]*\[[:blank:]*T(,[:blank:]*[:upper:]{1})*[:blank:]*\][:blank:]+pred[:blank:]+([:lower:]+([:alnum:]|[:punct:])*)+[:blank:]*\([^()]+\)([:blank:]|[:lower:])*\. Example: :- some [T] pred unravel_univ(univ::in, T::out) is det. Your fix incorrectly outputs such quantified predicates. For example on tagging univ.m (attached), your commit version yields: :- some [T] pred unravel_univ(^?[T] pred unravel_univ^A141,4333 whilst my original code yields the correct tag: :- some [T] pred unravel_univ(^?141,4333 In other words, 'pred unravel_univ' is wrongly repeated in your latest commit. The issue seems to be located at the patch line below: + char *name = skip_non_spaces (s + len0); Pending a more accurate 'fix for the fix', it would probably be wiser to revert to original code, as it - at least - gives a correct output for 'etags' invocation. Existentially quantified predicates are not uncommon in Mercury. Fabrice >> Date: Tue, 08 Jun 2021 14:47:13 +0200 >> Cc: fabrnicol@gmail.com, >> 47408@debbugs.gnu.org >> >>>> I just looked at the code. Unless I am grossly mistaken, nothing is >>>> needed to get ctags output. You just call the program as ctags and >>>> that's it. So there is no reason to prevent ctags help from mentioning >>>> Mercurial. >>> Then how come, when I run the etags test suite (test/manual/etags/), I >>> get no change in the produced CTAGS file wrt CTAGS.good? That .good >>> file is from before we added the Mercury source to the suite. What am >>> I missing? >> Sorry, don't know :( Looked again, but then I'd need to debug it to know... > I found the reason: make_tag was called incorrectly from mercury_pr. > > This should be fixed now. [-- Attachment #2: univ.m --] [-- Type: application/vnd.wolfram.mathematica.package, Size: 4841 bytes --] ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-10 16:52 ` fabrice nicol @ 2021-06-10 17:05 ` Francesco Potortì 2021-06-10 17:20 ` Eli Zaretskii 1 sibling, 0 replies; 27+ messages in thread From: Francesco Potortì @ 2021-06-10 17:05 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 >:- some [T] pred unravel_univ(univ::in, T::out) is det. > >Your fix incorrectly outputs such quantified predicates. For example on >tagging univ.m (attached), your commit version yields: > >:- some [T] pred unravel_univ(^?[T] pred unravel_univ^A141,4333 > >whilst my original code yields the correct tag: > >:- some [T] pred unravel_univ(^?141,4333 The first tag is a named tag, as described in etc/ETAGS.EBNF. Why do you say it is incorrect? Does etags.el behave badly with that tag? While the automatically generated explicit tag name should do no harm, if you generate a moreappropriate tag name that should improve functionality. In this case, I suspect that the tag name should be in fact "unravel_univ" rather than "pred unravel_univ". In short: 1) the first tag is anamed tag, and should behave essentially like the second, probably providing more resilience against code changes, so it shuld be the preferred way to generate a tag 2) this can be further improved with knowledge of the tagged langage: rather than relying on etags to autometically generate a name, the code should ideally provide the correct name ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-10 16:52 ` fabrice nicol 2021-06-10 17:05 ` Francesco Potortì @ 2021-06-10 17:20 ` Eli Zaretskii 2021-06-10 19:15 ` Eli Zaretskii 2021-06-10 20:39 ` bug#47408: Etags support for Mercury -- fix explicit tags for existentially-quantified procedures fabrice nicol 1 sibling, 2 replies; 27+ messages in thread From: Eli Zaretskii @ 2021-06-10 17:20 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 > Cc: 47408@debbugs.gnu.org > From: fabrice nicol <fabrnicol@gmail.com> > Date: Thu, 10 Jun 2021 18:52:49 +0200 > > your latest fix for Mercury 'etags' support has introduced a regression > for existentially quantified predicates. Is it a "regression" in the sense that "M-." no longer finds the definitions? > These predicates have the following (somewhat simplified) syntax (in > extended regexp form, \s for white space): > > :-[:blank:]+some[:blank:]*\[[:blank:]*T(,[:blank:]*[:upper:]{1})*[:blank:]*\][:blank:]+pred[:blank:]+([:lower:]+([:alnum:]|[:punct:])*)+[:blank:]*\([^()]+\)([:blank:]|[:lower:])*\. > > Example: > > :- some [T] pred unravel_univ(univ::in, T::out) is det. > > Your fix incorrectly outputs such quantified predicates. For example on > tagging univ.m (attached), your commit version yields: > > > :- some [T] pred unravel_univ(^?[T] pred unravel_univ^A141,4333 > > > whilst my original code yields the correct tag: > > > :- some [T] pred unravel_univ(^?141,4333 Why do you think the current result is incorrect, while the previous result was correct? > In other words, 'pred unravel_univ' is wrongly repeated in your latest > commit. It isn't "wrongly repeated". TAGS files support 2 different ways of specifying a tag: implicitly named or explicitly named. The "repeated name" form is the latter; it should be used whenever the NAME argument passed to make_tag includes characters that etags.el doesn't expect to find in an identifier; see the function notinname and the comments before make_tag. It should have been the job of mercury_pr to find the identifier itself within the line whose pointer it accepts as S, and pass only that to make_tag as NAME/NAMELEN arguments. I made a step in that direction, but it turns out I didn't go far enough. Feel free to propose improvements to the code I installed so as to identify the name of the identifier and nothing else, as other callers of make_tag do. > The issue seems to be located at the patch line below: > > > + char *name = skip_non_spaces (s + len0); The only problem with the above line is that it assumes there's only one non-space "word" before the identifier proper, whereas the example you show makes it clear there could be more than one. Which means the code might need to repeatedly skip these non-identifier words until we exhaust them all. I will look into fixing that (but I really prefer that you do it in my stead, as I don't know enough about the Mercury's syntax). But other than that, the changes I installed are IMO a step in the right direction: your original code incorrectly passed to make_tag the same arguments as both NAME and LINESTART, and passed zero as NAMELEN, which was the immediate reason why ctags didn't output anything for Mercury sources. Please compare the way you called make_tag with how the rest of the code calls that function. > Pending a more accurate 'fix for the fix', it would probably be wiser to > revert to original code, as it - at least - gives a correct output for > 'etags' invocation. The original code was incorrect, so it doesn't sound right to me to revert to it. I will work on fixing the cases you described (unless you beat me to it). Thanks for turning my attention to this issue. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury [v0.5] 2021-06-10 17:20 ` Eli Zaretskii @ 2021-06-10 19:15 ` Eli Zaretskii 2021-06-10 20:39 ` bug#47408: Etags support for Mercury -- fix explicit tags for existentially-quantified procedures fabrice nicol 1 sibling, 0 replies; 27+ messages in thread From: Eli Zaretskii @ 2021-06-10 19:15 UTC (permalink / raw) To: fabrnicol; +Cc: 47408 > Date: Thu, 10 Jun 2021 20:20:45 +0300 > From: Eli Zaretskii <eliz@gnu.org> > Cc: 47408@debbugs.gnu.org > > It should have been the job of mercury_pr to find the identifier > itself within the line whose pointer it accepts as S, and pass only > that to make_tag as NAME/NAMELEN arguments. I made a step in that > direction, but it turns out I didn't go far enough. Feel free to > propose improvements to the code I installed so as to identify the > name of the identifier and nothing else, as other callers of make_tag > do. > > > The issue seems to be located at the patch line below: > > > > > > + char *name = skip_non_spaces (s + len0); > > The only problem with the above line is that it assumes there's only > one non-space "word" before the identifier proper, whereas the example > you show makes it clear there could be more than one. Which means the > code might need to repeatedly skip these non-identifier words until we > exhaust them all. I will look into fixing that (but I really prefer > that you do it in my stead, as I don't know enough about the Mercury's > syntax). I think one way of solving this would be for mercury_decl to return more information to the caller than it currently does. That function already performs the necessary analysis of the line, and knows where the real identifier is located within that line. But it doesn't return that information to the caller. If it could return the pointer to the beginning of the identifier and the length of the identifier, it would allow mercury_pr to call make_tag correctly without doing again what mercury_decl already did. If you agree with this analysis, I'd be grateful if you could submit a patch along these lines. TIA. ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury -- fix explicit tags for existentially-quantified procedures 2021-06-10 17:20 ` Eli Zaretskii 2021-06-10 19:15 ` Eli Zaretskii @ 2021-06-10 20:39 ` fabrice nicol 2021-06-11 5:56 ` Eli Zaretskii 1 sibling, 1 reply; 27+ messages in thread From: fabrice nicol @ 2021-06-10 20:39 UTC (permalink / raw) To: Eli Zaretskii; +Cc: 47408 Hi Eli, >> your latest fix for Mercury 'etags' support has introduced a regression >> for existentially quantified predicates. > Is it a "regression" in the sense that "M-." no longer finds the > definitions? Exactly. M-. no longer finds the definition for existentially-quantified predicates (or functions), so this is a regression strictly speaking. Prior code did not abide by pfnote input constraints, but it "just worked" in all cases, at least for 'etags' invocation. >> These predicates have the following (somewhat simplified) syntax (in >> extended regexp form, \s for white space): >> >> :-[:blank:]+some[:blank:]*\[[:blank:]*T(,[:blank:]*[:upper:]{1})*[:blank:]*\][:blank:]+pred[:blank:]+([:lower:]+([:alnum:]|[:punct:])*)+[:blank:]*\([^()]+\)([:blank:]|[:lower:])*\. >> >> Example: >> >> :- some [T] pred unravel_univ(univ::in, T::out) is det. >> >> Your fix incorrectly outputs such quantified predicates. For example on >> tagging univ.m (attached), your commit version yields: >> >> >> :- some [T] pred unravel_univ(^?[T] pred unravel_univ^A141,4333 >> >> >> whilst my original code yields the correct tag: >> >> >> :- some [T] pred unravel_univ(^?141,4333 > Why do you think the current result is incorrect, while the previous > result was correct? The previous code issued TAGS file that were correctly parsed by 'etags' and so M-. / M-, "just worked" in all cases. The new code introduces such chunks as "[T] pred " at the beginning of explicit tags, which looks wrong and is likely to be the reason why these explicit tags are not parsed, hence useless. > > The original code was incorrect, so it doesn't sound right to me to > revert to it. I will work on fixing the cases you described (unless > you beat me to it). > > Thanks for turning my attention to this issue. I will not be able to spare enough free time to implement explicit tag parsing for existential predicates before a couple of weeks, so in the meantime, it would be safer to revert to original code and just flag/blame it as 'to-be-fixed for ctags by FN.' As I explained in prior mail, this is anyway a use case in which 'ctags' is not useful at all, whilst 'etags' is. Fabrice ^ permalink raw reply [flat|nested] 27+ messages in thread
* bug#47408: Etags support for Mercury -- fix explicit tags for existentially-quantified procedures 2021-06-10 20:39 ` bug#47408: Etags support for Mercury -- fix explicit tags for existentially-quantified procedures fabrice nicol @ 2021-06-11 5:56 ` Eli Zaretskii 0 siblings, 0 replies; 27+ messages in thread From: Eli Zaretskii @ 2021-06-11 5:56 UTC (permalink / raw) To: fabrice nicol; +Cc: 47408 > Cc: pot@gnu.org, 47408@debbugs.gnu.org > From: fabrice nicol <fabrnicol@gmail.com> > Date: Thu, 10 Jun 2021 22:39:29 +0200 > > Prior code did not abide by pfnote input constraints, but it "just > worked" in all cases, at least for 'etags' invocation. I'm afraid that was by sheer luck. The call to make_tag was incorrect. > I will not be able to spare enough free time to implement explicit tag > parsing for existential predicates before a couple of weeks, so in the > meantime, it would be safer to revert to original code and just > flag/blame it as 'to-be-fixed for ctags by FN.' Will you work on this after that time, or should I not rely on it and do it myself? Two weeks is not too long a time to wait for a solution. > As I explained in prior mail, this is anyway a use case in which 'ctags' > is not useful at all, whilst 'etags' is. As Francesco and myself explained, that would make Mercury the only such language, which I think is undesirable (and unnecessary). ^ permalink raw reply [flat|nested] 27+ messages in thread
end of thread, other threads:[~2021-06-11 5:56 UTC | newest]
Thread overview: 27+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
[not found] <25b8baef-11f2-7079-69d8-3207a24658fc@gmail.com>
2021-03-26 7:09 ` bug#47408: Emacs etags support for Mercury [v0.2] fabrice nicol
2021-03-27 10:51 ` bug#47408: Etags support for Mercury [v0.3] fabrice nicol
2021-03-28 13:11 ` Eli Zaretskii
2021-03-28 15:49 ` fabrice nicol
2021-03-28 16:22 ` Eli Zaretskii
2021-03-29 11:53 ` bug#47408: Etags support for Mercury [v0.4] fabrice nicol
[not found] ` <70503251-f8ea-9006-b7e7-b13b93bb71de@gmail.com>
2021-05-15 8:31 ` bug#47408: Fwd: " Eli Zaretskii
[not found] ` <53162dfb-0715-3077-78d1-3a8340943f2f@gmail.com>
2021-05-29 8:01 ` Eli Zaretskii
[not found] ` <CANTSrJtDMu=4SWUcBRt51X8n42mOfB6_sFi8mNoZ0YgYdtE-DA@mail.gmail.com>
2021-05-29 10:22 ` Eli Zaretskii
2021-06-01 2:38 ` bug#47408: Etags support for Mercury [v0.5] fabrice nicol
2021-06-06 9:48 ` Eli Zaretskii
2021-06-06 13:34 ` fabrice nicol
2021-06-06 18:18 ` Francesco Potortì
2021-06-06 20:49 ` fabrice nicol
2021-06-06 21:04 ` Francesco Potortì
2021-06-07 12:13 ` Eli Zaretskii
2021-06-08 0:38 ` Fabrice Nicol
2021-06-08 10:53 ` Francesco Potortì
2021-06-08 11:47 ` Eli Zaretskii
2021-06-08 12:47 ` Francesco Potortì
2021-06-10 13:59 ` Eli Zaretskii
2021-06-10 16:52 ` fabrice nicol
2021-06-10 17:05 ` Francesco Potortì
2021-06-10 17:20 ` Eli Zaretskii
2021-06-10 19:15 ` Eli Zaretskii
2021-06-10 20:39 ` bug#47408: Etags support for Mercury -- fix explicit tags for existentially-quantified procedures fabrice nicol
2021-06-11 5:56 ` Eli Zaretskii
Code repositories for project(s) associated with this external index https://git.savannah.gnu.org/cgit/emacs.git https://git.savannah.gnu.org/cgit/emacs/org-mode.git This is an external index of several public inboxes, see mirroring instructions on how to clone and mirror all data and code used by this external index.