tag:www.nabble.com,2006:forum-14116
Nabble - Mercury
2008-12-02T21:05:09Z
Mercury is a new logic/functional programming language, which combines the clarity and expressiveness of declarative programming with advanced static analysis and error detection features. Mercury home is <a href="http://www.cs.mu.oz.au/research/mercury/" target="_top" rel="nofollow">here</a>.
tag:www.nabble.com,2006:post-20806956
diff: fix context disagreement bug
2008-12-02T21:05:09Z
2008-12-02T21:05:09Z
Zoltan Somogyi-2
compiler/prog_io.m:
<br> Fix an old bug: don't insist that two parts of the same field access
<br> goal have the same context.
<br><br> Always get the context for field access goals from the ^ character.
<br><br>tests/hard_coded/field_access.m:
<br> Modify this old test case by giving different parts of a field access
<br> different contexts. The old version of the compiler mistakenly rejects
<br> it, but the fixed version accepts it.
<br><br>Zoltan.
<br><br>cvs diff: Diffing .
<br>cvs diff: Diffing analysis
<br>cvs diff: Diffing bindist
<br>cvs diff: Diffing boehm_gc
<br>cvs diff: Diffing boehm_gc/Mac_files
<br>cvs diff: Diffing boehm_gc/cord
<br>cvs diff: Diffing boehm_gc/cord/private
<br>cvs diff: Diffing boehm_gc/doc
<br>cvs diff: Diffing boehm_gc/include
<br>cvs diff: Diffing boehm_gc/include/private
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
<br>cvs diff: Diffing boehm_gc/tests
<br>cvs diff: Diffing boehm_gc/windows-untested
<br>cvs diff: Diffing boehm_gc/windows-untested/vc60
<br>cvs diff: Diffing boehm_gc/windows-untested/vc70
<br>cvs diff: Diffing boehm_gc/windows-untested/vc71
<br>cvs diff: Diffing browser
<br>cvs diff: Diffing bytecode
<br>cvs diff: Diffing compiler
<br>Index: compiler/prog_io.m
<br>===================================================================
<br>RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
<br>retrieving revision 1.296
<br>diff -u -b -r1.296 prog_io.m
<br>--- compiler/prog_io.m 3 Dec 2008 05:01:40 -0000 1.296
<br>+++ compiler/prog_io.m 3 Dec 2008 05:02:50 -0000
<br>@@ -2197,15 +2197,14 @@
<br>
<br> desugar_field_access(Term) = DesugaredTerm :-
<br> (
<br>- Term = functor(atom("^"), [A, RHS], _),
<br>- RHS = functor(atom(FieldName), Bs, Context)
<br>+ Term = functor(atom("^"), [A, RHS], Context),
<br>+ RHS = functor(atom(FieldName), Bs, _)
<br> ->
<br> DesugaredTerm = functor(atom(FieldName), Bs ++ [A], Context)
<br> ;
<br>- % XXX We shouldn't insist on the context of LHS and RHS being the same.
<br> Term = functor(atom(":="), [LHS, X], _),
<br> LHS = functor(atom("^"), [A, RHS], Context),
<br>- RHS = functor(atom(FieldName), Bs, Context)
<br>+ RHS = functor(atom(FieldName), Bs, _)
<br> ->
<br> FunctionName = FieldName ++ " :=",
<br> DesugaredTerm = functor(atom(FunctionName), Bs ++ [A, X], Context)
<br>cvs diff: Diffing compiler/notes
<br>cvs diff: Diffing debian
<br>cvs diff: Diffing debian/patches
<br>cvs diff: Diffing deep_profiler
<br>cvs diff: Diffing deep_profiler/notes
<br>cvs diff: Diffing doc
<br>cvs diff: Diffing extras
<br>cvs diff: Diffing extras/base64
<br>cvs diff: Diffing extras/cgi
<br>cvs diff: Diffing extras/complex_numbers
<br>cvs diff: Diffing extras/complex_numbers/samples
<br>cvs diff: Diffing extras/complex_numbers/tests
<br>cvs diff: Diffing extras/concurrency
<br>cvs diff: Diffing extras/curs
<br>cvs diff: Diffing extras/curs/samples
<br>cvs diff: Diffing extras/curses
<br>cvs diff: Diffing extras/curses/sample
<br>cvs diff: Diffing extras/dynamic_linking
<br>cvs diff: Diffing extras/error
<br>cvs diff: Diffing extras/fixed
<br>cvs diff: Diffing extras/gator
<br>cvs diff: Diffing extras/gator/generations
<br>cvs diff: Diffing extras/gator/generations/1
<br>cvs diff: Diffing extras/graphics
<br>cvs diff: Diffing extras/graphics/easyx
<br>cvs diff: Diffing extras/graphics/easyx/samples
<br>cvs diff: Diffing extras/graphics/mercury_allegro
<br>cvs diff: Diffing extras/graphics/mercury_allegro/examples
<br>cvs diff: Diffing extras/graphics/mercury_allegro/samples
<br>cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
<br>cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
<br>cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
<br>cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
<br>cvs diff: Diffing extras/graphics/mercury_glut
<br>cvs diff: Diffing extras/graphics/mercury_opengl
<br>cvs diff: Diffing extras/graphics/mercury_tcltk
<br>cvs diff: Diffing extras/graphics/samples
<br>cvs diff: Diffing extras/graphics/samples/calc
<br>cvs diff: Diffing extras/graphics/samples/gears
<br>cvs diff: Diffing extras/graphics/samples/maze
<br>cvs diff: Diffing extras/graphics/samples/pent
<br>cvs diff: Diffing extras/lazy_evaluation
<br>cvs diff: Diffing extras/lex
<br>cvs diff: Diffing extras/lex/samples
<br>cvs diff: Diffing extras/lex/tests
<br>cvs diff: Diffing extras/log4m
<br>cvs diff: Diffing extras/logged_output
<br>cvs diff: Diffing extras/moose
<br>cvs diff: Diffing extras/moose/samples
<br>cvs diff: Diffing extras/moose/tests
<br>cvs diff: Diffing extras/mopenssl
<br>cvs diff: Diffing extras/morphine
<br>cvs diff: Diffing extras/morphine/non-regression-tests
<br>cvs diff: Diffing extras/morphine/scripts
<br>cvs diff: Diffing extras/morphine/source
<br>cvs diff: Diffing extras/net
<br>cvs diff: Diffing extras/odbc
<br>cvs diff: Diffing extras/posix
<br>cvs diff: Diffing extras/posix/samples
<br>cvs diff: Diffing extras/quickcheck
<br>cvs diff: Diffing extras/quickcheck/tutes
<br>cvs diff: Diffing extras/references
<br>cvs diff: Diffing extras/references/samples
<br>cvs diff: Diffing extras/references/tests
<br>cvs diff: Diffing extras/solver_types
<br>cvs diff: Diffing extras/solver_types/library
<br>cvs diff: Diffing extras/trailed_update
<br>cvs diff: Diffing extras/trailed_update/samples
<br>cvs diff: Diffing extras/trailed_update/tests
<br>cvs diff: Diffing extras/windows_installer_generator
<br>cvs diff: Diffing extras/windows_installer_generator/sample
<br>cvs diff: Diffing extras/windows_installer_generator/sample/images
<br>cvs diff: Diffing extras/xml
<br>cvs diff: Diffing extras/xml/samples
<br>cvs diff: Diffing extras/xml_stylesheets
<br>cvs diff: Diffing java
<br>cvs diff: Diffing java/runtime
<br>cvs diff: Diffing library
<br>cvs diff: Diffing mdbcomp
<br>cvs diff: Diffing profiler
<br>cvs diff: Diffing robdd
<br>cvs diff: Diffing runtime
<br>cvs diff: Diffing runtime/GETOPT
<br>cvs diff: Diffing runtime/machdeps
<br>cvs diff: Diffing samples
<br>cvs diff: Diffing samples/c_interface
<br>cvs diff: Diffing samples/c_interface/c_calls_mercury
<br>cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
<br>cvs diff: Diffing samples/c_interface/mercury_calls_c
<br>cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
<br>cvs diff: Diffing samples/c_interface/mercury_calls_fortran
<br>cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
<br>cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
<br>cvs diff: Diffing samples/c_interface/standalone_c
<br>cvs diff: Diffing samples/diff
<br>cvs diff: Diffing samples/muz
<br>cvs diff: Diffing samples/rot13
<br>cvs diff: Diffing samples/solutions
<br>cvs diff: Diffing samples/solver_types
<br>cvs diff: Diffing samples/tests
<br>cvs diff: Diffing samples/tests/c_interface
<br>cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
<br>cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
<br>cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
<br>cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
<br>cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
<br>cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
<br>cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
<br>cvs diff: Diffing samples/tests/diff
<br>cvs diff: Diffing samples/tests/muz
<br>cvs diff: Diffing samples/tests/rot13
<br>cvs diff: Diffing samples/tests/solutions
<br>cvs diff: Diffing samples/tests/toplevel
<br>cvs diff: Diffing scripts
<br>cvs diff: Diffing slice
<br>cvs diff: Diffing ssdb
<br>cvs diff: Diffing tests
<br>cvs diff: Diffing tests/analysis
<br>cvs diff: Diffing tests/analysis/ctgc
<br>cvs diff: Diffing tests/analysis/excp
<br>cvs diff: Diffing tests/analysis/ext
<br>cvs diff: Diffing tests/analysis/sharing
<br>cvs diff: Diffing tests/analysis/table
<br>cvs diff: Diffing tests/analysis/trail
<br>cvs diff: Diffing tests/analysis/unused_args
<br>cvs diff: Diffing tests/benchmarks
<br>cvs diff: Diffing tests/debugger
<br>cvs diff: Diffing tests/debugger/declarative
<br>cvs diff: Diffing tests/dppd
<br>cvs diff: Diffing tests/general
<br>cvs diff: Diffing tests/general/accumulator
<br>cvs diff: Diffing tests/general/string_format
<br>cvs diff: Diffing tests/general/structure_reuse
<br>cvs diff: Diffing tests/grade_subdirs
<br>cvs diff: Diffing tests/hard_coded
<br>Index: tests/hard_coded/field_syntax.m
<br>===================================================================
<br>RCS file: /home/mercury/mercury1/repository/tests/hard_coded/field_syntax.m,v
<br>retrieving revision 1.1
<br>diff -u -b -r1.1 field_syntax.m
<br>--- tests/hard_coded/field_syntax.m 16 Jan 2003 02:34:35 -0000 1.1
<br>+++ tests/hard_coded/field_syntax.m 3 Dec 2008 01:00:41 -0000
<br>@@ -35,7 +35,20 @@
<br> :- func (array(T) ^ elem_from_end(int) := T) = array(T).
<br> :- mode (array_di ^ elem_from_end(in) := in) = array_uo is det.
<br>
<br>-(A ^ elem_from_end(I) := X) = (A ^ elem(max(A) - I) := X).
<br>+% This formatting gives each part of the term a different context.
<br>+% This is a regression test for a bug in which the code that recognized
<br>+% field accesses insisted on the same context for parts of the term.
<br>+(A
<br>+ ^
<br>+ elem_from_end(I)
<br>+ :=
<br>+ X)
<br>+ =
<br>+ (A
<br>+ ^
<br>+ elem(max(A) - I)
<br>+ :=
<br>+ X).
<br>
<br> %-----------------------------------------------------------------------------%
<br>
<br>cvs diff: Diffing tests/hard_coded/exceptions
<br>cvs diff: Diffing tests/hard_coded/purity
<br>cvs diff: Diffing tests/hard_coded/sub-modules
<br>cvs diff: Diffing tests/hard_coded/typeclasses
<br>cvs diff: Diffing tests/invalid
<br>cvs diff: Diffing tests/invalid/purity
<br>cvs diff: Diffing tests/misc_tests
<br>cvs diff: Diffing tests/mmc_make
<br>cvs diff: Diffing tests/mmc_make/lib
<br>cvs diff: Diffing tests/par_conj
<br>cvs diff: Diffing tests/recompilation
<br>cvs diff: Diffing tests/tabling
<br>cvs diff: Diffing tests/term
<br>cvs diff: Diffing tests/trailing
<br>cvs diff: Diffing tests/valid
<br>cvs diff: Diffing tests/warnings
<br>cvs diff: Diffing tools
<br>cvs diff: Diffing trace
<br>cvs diff: Diffing util
<br>cvs diff: Diffing vim
<br>cvs diff: Diffing vim/after
<br>cvs diff: Diffing vim/ftplugin
<br>cvs diff: Diffing vim/syntax
<br>--------------------------------------------------------------------------
<br>mercury-reviews mailing list
<br>Post messages to: <a href="http://www.nabble.com/user/SendEmail.jtp?type=post&post=20806956&i=0" target="_top" rel="nofollow">mercury-reviews@...</a>
<br>Administrative Queries: <a href="http://www.nabble.com/user/SendEmail.jtp?type=post&post=20806956&i=1" target="_top" rel="nofollow">owner-mercury-reviews@...</a>
<br>Subscriptions: <a href="http://www.nabble.com/user/SendEmail.jtp?type=post&post=20806956&i=2" target="_top" rel="nofollow">mercury-reviews-request@...</a>
<br>--------------------------------------------------------------------------
<br><p>From forum: <a href="http://www.nabble.com/Mercury---Reviews-f14121.html" embed="fixTarget[14121]" target="_top" >Mercury - Reviews</a></p>
tag:www.nabble.com,2006:post-20806950
diff: prog_io_{mode,type}_defn.m
2008-12-02T21:01:01Z
2008-12-02T21:01:01Z
Zoltan Somogyi-2
Hopefully finish the breakup of the monster module prog_io.m. It is now way
<br>out of the list of the ten biggest modules. More important, it now has much
<br>more coherence: it consists mainly of
<br><br>- the top level loop for reading in items, and
<br>- the code for parsing predicate, function and mode declarations.
<br><br>There are still some other misc things that don't fit here (e.g. checking insts
<br>for consistency), but they don't fit that well in other modules either.
<br><br>compiler/prog_io.m:
<br>compiler/prog_io_mode_defn.m:
<br>compiler/prog_io_type_defn.m:
<br> Move the code in prog_io.m for dealing with definitions of insts, modes
<br> and types into two new modules.
<br><br> Delete some obsolete comments at the top of prog_io.m..
<br><br>compiler/prog_io_util.m:
<br> Move some generic stuff for dealing with declaration attributes and
<br> (nonsupported) conditions here from prog_io.m, since the module
<br> prog_io_type_defn.m also needs them.
<br><br>compiler/parse_tree.m:
<br>compiler/notes/compiler_design.html:
<br> Add the new modules.
<br><br>compiler/*.m:
<br> Import the new modules where needed.
<br><br>Zoltan.
<br><br>cvs diff: Diffing .
<br>cvs diff: Diffing analysis
<br>cvs diff: Diffing bindist
<br>cvs diff: Diffing boehm_gc
<br>cvs diff: Diffing boehm_gc/Mac_files
<br>cvs diff: Diffing boehm_gc/cord
<br>cvs diff: Diffing boehm_gc/cord/private
<br>cvs diff: Diffing boehm_gc/doc
<br>cvs diff: Diffing boehm_gc/include
<br>cvs diff: Diffing boehm_gc/include/private
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
<br>cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
<br>cvs diff: Diffing boehm_gc/tests
<br>cvs diff: Diffing boehm_gc/windows-untested
<br>cvs diff: Diffing boehm_gc/windows-untested/vc60
<br>cvs diff: Diffing boehm_gc/windows-untested/vc70
<br>cvs diff: Diffing boehm_gc/windows-untested/vc71
<br>cvs diff: Diffing browser
<br>cvs diff: Diffing bytecode
<br>cvs diff: Diffing compiler
<br>Index: compiler/parse_tree.m
<br>===================================================================
<br>RCS file: /home/mercury/mercury1/repository/mercury/compiler/parse_tree.m,v
<br>retrieving revision 1.19
<br>diff -u -b -r1.19 parse_tree.m
<br>--- compiler/parse_tree.m 2 Dec 2008 04:30:24 -0000 1.19
<br>+++ compiler/parse_tree.m 2 Dec 2008 05:33:17 -0000
<br>@@ -30,9 +30,11 @@
<br> :- include_module prog_io.
<br> :- include_module prog_io_dcg.
<br> :- include_module prog_io_goal.
<br>+ :- include_module prog_io_mode_defn.
<br> :- include_module prog_io_mutable.
<br> :- include_module prog_io_pragma.
<br> :- include_module prog_io_sym_name.
<br>+ :- include_module prog_io_type_defn.
<br> :- include_module prog_io_typeclass.
<br> :- include_module prog_io_util.
<br>
<br>Index: compiler/prog_io.m
<br>===================================================================
<br>RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
<br>retrieving revision 1.295
<br>diff -u -b -r1.295 prog_io.m
<br>--- compiler/prog_io.m 2 Dec 2008 04:30:24 -0000 1.295
<br>+++ compiler/prog_io.m 2 Dec 2008 06:47:53 -0000
<br>@@ -32,16 +32,6 @@
<br> % Simplifications are done only by make_hlds.m, which transforms
<br> % the parse tree which we built here into the HLDS.
<br> %
<br>-% Some of this code is a rather bad example of cut-and-paste style reuse.
<br>-% It should be cleaned up to eliminate most of the duplication.
<br>-% But that task really needs to wait until we implement higher-order
<br>-% predicates. For the moment, just be careful that any changes
<br>-% you make are reflected correctly in all similar parts of this file.
<br>-%
<br>-% Implication and equivalence implemented by squirrel, who would also
<br>-% like to get her hands on this file and give it a good clean up and
<br>-% put it into good clean "mercury" style!
<br>-%
<br> % Wishlist:
<br> %
<br> % 1. implement importing/exporting operators with a particular fixity
<br>@@ -162,24 +152,6 @@
<br> :- pred parse_decl(module_name::in, varset::in, term::in, int::in,
<br> maybe1(item)::out) is det.
<br>
<br>- % parse_type_defn_head(ModuleName, VarSet, Head, HeadResult):
<br>- %
<br>- % Check the head of a type definition for errors.
<br>- %
<br>-:- pred parse_type_defn_head(module_name::in, varset::in, term::in,
<br>- maybe2(sym_name, list(type_param))::out) is det.
<br>-
<br>- % parse_type_decl_where_part_if_present(TypeSymName, Arity,
<br>- % IsSolverType, Inst, ModuleName, Term0, Term, Result):
<br>- %
<br>- % Checks if Term0 is a term of the form `<body> where <attributes>'.
<br>- % If so, returns the `<body>' in Term and the parsed `<attributes>'
<br>- % in Result. If not, returns Term = Term0 and Result = no.
<br>- %
<br>-:- pred parse_type_decl_where_part_if_present(is_solver_type::in,
<br>- module_name::in, varset::in, term::in, term::out,
<br>- maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det.
<br>-
<br> %-----------------------------------------------------------------------------%
<br>
<br> % Replace all occurrences of inst_var(I) with
<br>@@ -214,9 +186,11 @@
<br> :- import_module parse_tree.mercury_to_mercury.
<br> :- import_module parse_tree.prog_io_dcg.
<br> :- import_module parse_tree.prog_io_goal.
<br>+:- import_module parse_tree.prog_io_mode_defn.
<br> :- import_module parse_tree.prog_io_mutable.
<br> :- import_module parse_tree.prog_io_pragma.
<br> :- import_module parse_tree.prog_io_sym_name.
<br>+:- import_module parse_tree.prog_io_type_defn.
<br> :- import_module parse_tree.prog_io_typeclass.
<br> :- import_module parse_tree.prog_io_util.
<br> :- import_module parse_tree.prog_mode.
<br>@@ -1027,23 +1001,6 @@
<br>
<br> %-----------------------------------------------------------------------------%
<br>
<br>-:- type decl_attribute
<br>- ---> decl_attr_purity(purity)
<br>- ; decl_attr_quantifier(quantifier_type, list(var))
<br>- ; decl_attr_constraints(quantifier_type, term)
<br>- % the term here is the (not yet parsed) list of constraints
<br>- ; decl_attr_solver_type.
<br>-
<br>-:- type quantifier_type
<br>- ---> quant_type_exist
<br>- ; quant_type_univ.
<br>-
<br>- % The term associated with each decl_attribute is the term containing
<br>- % both the attribute and the declaration that that attribute modifies;
<br>- % this term is used when printing out error messages for cases when
<br>- % attributes are used on declarations where they are not allowed.
<br>-:- type decl_attrs == assoc_list(decl_attribute, term.context).
<br>-
<br> parse_decl(ModuleName, VarSet, Term, SeqNum, MaybeItem) :-
<br> parse_attrs_and_decl(ModuleName, VarSet, Term, [], SeqNum, MaybeItem).
<br>
<br>@@ -1384,1401 +1341,6 @@
<br> )
<br> ).
<br>
<br>-:- pred parse_decl_attribute(string::in, list(term)::in, decl_attribute::out,
<br>- term::out) is semidet.
<br>-
<br>-parse_decl_attribute(Functor, ArgTerms, Attribute, SubTerm) :-
<br>- (
<br>- Functor = "impure",
<br>- ArgTerms = [SubTerm],
<br>- Attribute = decl_attr_purity(purity_impure)
<br>- ;
<br>- Functor = "semipure",
<br>- ArgTerms = [SubTerm],
<br>- Attribute = decl_attr_purity(purity_semipure)
<br>- ;
<br>- Functor = "<=",
<br>- ArgTerms = [SubTerm, ConstraintsTerm],
<br>- Attribute = decl_attr_constraints(quant_type_univ, ConstraintsTerm)
<br>- ;
<br>- Functor = "=>",
<br>- ArgTerms = [SubTerm, ConstraintsTerm],
<br>- Attribute = decl_attr_constraints(quant_type_exist, ConstraintsTerm)
<br>- ;
<br>- Functor = "some",
<br>- ArgTerms = [TVarsTerm, SubTerm],
<br>- parse_list_of_vars(TVarsTerm, TVars),
<br>- Attribute = decl_attr_quantifier(quant_type_exist, TVars)
<br>- ;
<br>- Functor = "all",
<br>- ArgTerms = [TVarsTerm, SubTerm],
<br>- parse_list_of_vars(TVarsTerm, TVars),
<br>- Attribute = decl_attr_quantifier(quant_type_univ, TVars)
<br>- ;
<br>- Functor = "solver",
<br>- ArgTerms = [SubTerm],
<br>- Attribute = decl_attr_solver_type
<br>- ).
<br>-
<br>-:- pred check_no_attributes(maybe1(T)::in, decl_attrs::in, maybe1(T)::out)
<br>- is det.
<br>-
<br>-check_no_attributes(Result0, Attributes, Result) :-
<br>- (
<br>- Result0 = ok1(_),
<br>- Attributes = [Attr - Context | _]
<br>- ->
<br>- % XXX Shouldn't we mention EVERY element of Attributes?
<br>- Pieces = [words("Error:"), words(attribute_description(Attr)),
<br>- words("not allowed here."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(Context, [always(Pieces)])]),
<br>- Result = error1([Spec])
<br>- ;
<br>- Result = Result0
<br>- ).
<br>-
<br>-:- func attribute_description(decl_attribute) = string.
<br>-
<br>-attribute_description(decl_attr_purity(_)) = "purity specifier".
<br>-attribute_description(decl_attr_quantifier(quant_type_univ, _)) =
<br>- "universal quantifier (`all')".
<br>-attribute_description(decl_attr_quantifier(quant_type_exist, _)) =
<br>- "existential quantifier (`some')".
<br>-attribute_description(decl_attr_constraints(quant_type_univ, _)) =
<br>- "type class constraint (`<=')".
<br>-attribute_description(decl_attr_constraints(quant_type_exist, _)) =
<br>- "existentially quantified type class constraint (`=>')".
<br>-attribute_description(decl_attr_solver_type) = "solver type specifier".
<br>-
<br>-%-----------------------------------------------------------------------------%
<br>-%-----------------------------------------------------------------------------%
<br>-%
<br>-% Parsing type definitions.
<br>-%
<br>-
<br>- % parse_type_defn parses the definition of a type.
<br>- %
<br>-:- pred parse_type_defn(module_name::in, varset::in, term::in, decl_attrs::in,
<br>- prog_context::in, int::in, maybe1(item)::out) is det.
<br>-
<br>-parse_type_defn(ModuleName, VarSet, TypeDefnTerm, Attributes, Context,
<br>- SeqNum, MaybeItem) :-
<br>- (
<br>- TypeDefnTerm = term.functor(term.atom(Name), ArgTerms, _),
<br>- ArgTerms = [HeadTerm, BodyTerm],
<br>- ( Name = "--->"
<br>- ; Name = "=="
<br>- ; Name = "where"
<br>- )
<br>- ->
<br>- parse_condition_suffix(BodyTerm, BeforeCondTerm, Condition),
<br>- (
<br>- Name = "--->",
<br>- parse_du_type_defn(ModuleName, VarSet,
<br>- HeadTerm, BeforeCondTerm, Attributes,
<br>- Condition, Context, SeqNum, MaybeItem)
<br>- ;
<br>- Name = "==",
<br>- parse_eqv_type_defn(ModuleName, VarSet,
<br>- HeadTerm, BeforeCondTerm, Attributes,
<br>- Condition, Context, SeqNum, MaybeItem)
<br>- ;
<br>- Name = "where",
<br>- parse_solver_type_defn(ModuleName, VarSet,
<br>- HeadTerm, BeforeCondTerm, Attributes,
<br>- Condition, Context, SeqNum, MaybeItem)
<br>- )
<br>- ;
<br>- parse_abstract_type_defn(ModuleName, VarSet, TypeDefnTerm, Attributes,
<br>- Condition, Context, SeqNum, MaybeItem),
<br>- Condition = cond_true
<br>- ).
<br>-
<br>-%-----------------------------------------------------------------------------%
<br>-%
<br>-% Code dealing with definitions of discriminated union types.
<br>-%
<br>-
<br>- % parse_du_type_defn parses the definition of a discriminated union type.
<br>- %
<br>-:- pred parse_du_type_defn(module_name::in, varset::in, term::in, term::in,
<br>- decl_attrs::in, condition::in, prog_context::in, int::in,
<br>- maybe1(item)::out) is det.
<br>-
<br>-parse_du_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
<br>- Condition, Context, SeqNum, MaybeItem) :-
<br>- get_is_solver_type(IsSolverType, Attributes0, Attributes),
<br>- (
<br>- IsSolverType = solver_type,
<br>- Pieces = [words("Error: a solver type"),
<br>- words("cannot have data constructors."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
<br>- MaybeItem = error1([Spec])
<br>- ;
<br>- IsSolverType = non_solver_type,
<br>- parse_type_defn_head(ModuleName, VarSet, HeadTerm,
<br>- MaybeTypeCtorAndArgs),
<br>- du_type_rhs_ctors_and_where_terms(BodyTerm, CtorsTerm, MaybeWhereTerm),
<br>- MaybeCtors = parse_constructors(ModuleName, VarSet, CtorsTerm),
<br>- MaybeWhere = parse_type_decl_where_term(non_solver_type,
<br>- ModuleName, VarSet, MaybeWhereTerm),
<br>- % The code to process `where' attributes will return an error
<br>- % if solver attributes are given for a non-solver type. Because
<br>- % this is a du type, if the unification with MaybeWhere succeeds
<br>- % then _NoSolverTypeDetails is guaranteed to be `no'.
<br>- (
<br>- MaybeTypeCtorAndArgs = ok2(Name, Params),
<br>- MaybeCtors = ok1(Ctors),
<br>- MaybeWhere = ok2(_NoSolverTypeDetails, MaybeUserEqComp)
<br>- ->
<br>- process_du_ctors(Params, VarSet, BodyTerm, Ctors, [], CtorsSpecs),
<br>- (
<br>- CtorsSpecs = [],
<br>- varset.coerce(VarSet, TypeVarSet),
<br>- TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp),
<br>- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
<br>- TypeDefn, Condition, Context, SeqNum),
<br>- Item = item_type_defn(ItemTypeDefn),
<br>- MaybeItem0 = ok1(Item),
<br>- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
<br>- ;
<br>- CtorsSpecs = [_ | _],
<br>- MaybeItem = error1(CtorsSpecs)
<br>- )
<br>- ;
<br>- Specs = get_any_errors2(MaybeTypeCtorAndArgs) ++
<br>- get_any_errors1(MaybeCtors) ++ get_any_errors2(MaybeWhere),
<br>- MaybeItem = error1(Specs)
<br>- )
<br>- ).
<br>-
<br>-:- pred du_type_rhs_ctors_and_where_terms(term::in,
<br>- term::out, maybe(term)::out) is det.
<br>-
<br>-du_type_rhs_ctors_and_where_terms(Term, CtorsTerm, MaybeWhereTerm) :-
<br>- (
<br>- Term = term.functor(term.atom("where"), Args, _Context),
<br>- Args = [CtorsTerm0, WhereTerm]
<br>- ->
<br>- CtorsTerm = CtorsTerm0,
<br>- MaybeWhereTerm = yes(WhereTerm)
<br>- ;
<br>- CtorsTerm = Term,
<br>- MaybeWhereTerm = no
<br>- ).
<br>-
<br>- % Convert a list of terms separated by semi-colons (known as a
<br>- % "disjunction", even thought the terms aren't goals in this case)
<br>- % into a list of constructors.
<br>- %
<br>-:- func parse_constructors(module_name, varset, term) =
<br>- maybe1(list(constructor)).
<br>-
<br>-parse_constructors(ModuleName, VarSet, Term) = MaybeConstructors :-
<br>- disjunction_to_list(Term, BodyTermList),
<br>- MaybeConstructors = parse_constructors_2(ModuleName, VarSet, BodyTermList).
<br>-
<br>- % True if the term is a valid list of constructors.
<br>- %
<br>-:- func parse_constructors_2(module_name, varset, list(term)) =
<br>- maybe1(list(constructor)).
<br>-
<br>-parse_constructors_2(_ModuleName, _, []) = ok1([]).
<br>-parse_constructors_2(ModuleName, VarSet, [Head | Tail]) = MaybeConstructors :-
<br>- MaybeHeadConstructor = parse_constructor(ModuleName, VarSet, Head),
<br>- MaybeTailConstructors = parse_constructors_2(ModuleName, VarSet, Tail),
<br>- (
<br>- MaybeHeadConstructor = ok1(HeadConstructor),
<br>- MaybeTailConstructors = ok1(TailConstructors)
<br>- ->
<br>- Constructors = [HeadConstructor | TailConstructors],
<br>- MaybeConstructors = ok1(Constructors)
<br>- ;
<br>- Specs = get_any_errors1(MaybeHeadConstructor) ++
<br>- get_any_errors1(MaybeTailConstructors),
<br>- MaybeConstructors = error1(Specs)
<br>- ).
<br>-
<br>-:- func parse_constructor(module_name, varset, term) = maybe1(constructor).
<br>-
<br>-parse_constructor(ModuleName, VarSet, Term) = MaybeConstructor :-
<br>- ( Term = term.functor(term.atom("some"), [VarsTerm, SubTerm], _) ->
<br>- ( parse_list_of_vars(VarsTerm, ExistQVars) ->
<br>- list.map(term.coerce_var, ExistQVars, ExistQTVars),
<br>- MaybeConstructor = parse_constructor_2(ModuleName, VarSet,
<br>- ExistQTVars, Term, SubTerm)
<br>- ;
<br>- TermStr = describe_error_term(VarSet, Term),
<br>- Pieces = [words("Error: syntax error in variable list at"),
<br>- words(TermStr), suffix("."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(VarsTerm), [always(Pieces)])]),
<br>- MaybeConstructor = error1([Spec])
<br>- )
<br>- ;
<br>- ExistQVars = [],
<br>- MaybeConstructor = parse_constructor_2(ModuleName, VarSet, ExistQVars,
<br>- Term, Term)
<br>- ).
<br>-
<br>-:- func parse_constructor_2(module_name, varset, list(tvar), term, term) =
<br>- maybe1(constructor).
<br>-
<br>-parse_constructor_2(ModuleName, VarSet, ExistQVars, ContainingTerm, Term)
<br>- = MaybeConstructor :-
<br>- get_existential_constraints_from_term(ModuleName, VarSet, Term,
<br>- BeforeConstraintsTerm, MaybeConstraints),
<br>- (
<br>- MaybeConstraints = error1(Specs),
<br>- MaybeConstructor = error1(Specs)
<br>- ;
<br>- MaybeConstraints = ok1(Constraints),
<br>- (
<br>- % Note that as a special case, one level of curly braces around
<br>- % the constructor are ignored. This is to allow you to define
<br>- % ';'/2 and 'some'/2 constructors.
<br>- BeforeConstraintsTerm = term.functor(term.atom("{}"),
<br>- [InsideBracesTerm], _Context)
<br>- ->
<br>- MainTerm = InsideBracesTerm
<br>- ;
<br>- MainTerm = BeforeConstraintsTerm
<br>- ),
<br>- ContextPieces = [words("In constructor definition:")],
<br>- parse_implicitly_qualified_term(ModuleName, MainTerm, ContainingTerm,
<br>- VarSet, ContextPieces, MaybeFunctorAndArgTerms),
<br>- (
<br>- MaybeFunctorAndArgTerms = error2(Specs),
<br>- MaybeConstructor = error1(Specs)
<br>- ;
<br>- MaybeFunctorAndArgTerms = ok2(Functor, ArgTerms),
<br>- MaybeConstructorArgs = convert_constructor_arg_list(ModuleName,
<br>- VarSet, ArgTerms),
<br>- (
<br>- MaybeConstructorArgs = error1(Specs),
<br>- MaybeConstructor = error1(Specs)
<br>- ;
<br>- MaybeConstructorArgs = ok1(ConstructorArgs),
<br>- Ctor = ctor(ExistQVars, Constraints, Functor, ConstructorArgs,
<br>- get_term_context(MainTerm)),
<br>- MaybeConstructor = ok1(Ctor)
<br>- )
<br>- )
<br>- ).
<br>-
<br>-:- pred get_existential_constraints_from_term(module_name::in, varset::in,
<br>- term::in, term::out, maybe1(list(prog_constraint))::out) is det.
<br>-
<br>-get_existential_constraints_from_term(ModuleName, VarSet, !PredTypeTerm,
<br>- MaybeExistentialConstraints) :-
<br>- (
<br>- !.PredTypeTerm = term.functor(term.atom("=>"),
<br>- [!:PredTypeTerm, ExistentialConstraints], _)
<br>- ->
<br>- parse_class_constraints(ModuleName, VarSet, ExistentialConstraints,
<br>- MaybeExistentialConstraints)
<br>- ;
<br>- MaybeExistentialConstraints = ok1([])
<br>- ).
<br>-
<br>-:- func convert_constructor_arg_list(module_name, varset, list(term)) =
<br>- maybe1(list(constructor_arg)).
<br>-
<br>-convert_constructor_arg_list(_, _, []) = ok1([]).
<br>-convert_constructor_arg_list(ModuleName, VarSet, [Term | Terms])
<br>- = MaybeConstructorArgs :-
<br>- ( Term = term.functor(term.atom("::"), [NameTerm, TypeTerm], _) ->
<br>- ContextPieces = [words("In field name:")],
<br>- parse_implicitly_qualified_term(ModuleName, NameTerm, Term,
<br>- VarSet, ContextPieces, MaybeSymNameAndArgs),
<br>- (
<br>- MaybeSymNameAndArgs = error2(Specs),
<br>- MaybeConstructorArgs = error1(Specs)
<br>- ;
<br>- MaybeSymNameAndArgs = ok2(SymName, SymNameArgs),
<br>- (
<br>- SymNameArgs = [_ | _],
<br>- % XXX Should we add "... at function symbol ..."?
<br>- Pieces = [words("Error: syntax error in constructor name."),
<br>- nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(Term), [always(Pieces)])]),
<br>- MaybeConstructorArgs = error1([Spec])
<br>- ;
<br>- SymNameArgs = [],
<br>- MaybeFieldName = yes(SymName),
<br>- MaybeConstructorArgs =
<br>- convert_constructor_arg_list_2(ModuleName,
<br>- VarSet, MaybeFieldName, TypeTerm, Terms)
<br>- )
<br>- )
<br>- ;
<br>- MaybeFieldName = no,
<br>- TypeTerm = Term,
<br>- MaybeConstructorArgs = convert_constructor_arg_list_2(ModuleName,
<br>- VarSet, MaybeFieldName, TypeTerm, Terms)
<br>- ).
<br>-
<br>-:- func convert_constructor_arg_list_2(module_name, varset, maybe(sym_name),
<br>- term, list(term)) = maybe1(list(constructor_arg)).
<br>-
<br>-convert_constructor_arg_list_2(ModuleName, VarSet, MaybeFieldName,
<br>- TypeTerm, Terms) = MaybeArgs :-
<br>- ContextPieces = [words("In type definition:")],
<br>- parse_type(TypeTerm, VarSet, ContextPieces, MaybeType),
<br>- (
<br>- MaybeType = ok1(Type),
<br>- Context = get_term_context(TypeTerm),
<br>- Arg = ctor_arg(MaybeFieldName, Type, Context),
<br>- MaybeTailArgs =
<br>- convert_constructor_arg_list(ModuleName, VarSet, Terms),
<br>- (
<br>- MaybeTailArgs = error1(Specs),
<br>- MaybeArgs = error1(Specs)
<br>- ;
<br>- MaybeTailArgs = ok1(Args),
<br>- MaybeArgs = ok1([Arg | Args])
<br>- )
<br>- ;
<br>- MaybeType = error1(Specs),
<br>- MaybeArgs = error1(Specs)
<br>- ).
<br>-
<br>-:- pred process_du_ctors(list(type_param)::in, varset::in, term::in,
<br>- list(constructor)::in, list(error_spec)::in, list(error_spec)::out) is det.
<br>-
<br>-process_du_ctors(_Params, _, _, [], !Specs).
<br>-process_du_ctors(Params, VarSet, BodyTerm, [Ctor | Ctors], !Specs) :-
<br>- Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs, _Context),
<br>- (
<br>- % Check that all type variables in the ctor are either explicitly
<br>- % existentially quantified or occur in the head of the type.
<br>-
<br>- CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
<br>- type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
<br>- list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
<br>- list.filter(list.contains(ExistQVars ++ Params), VarsInCtorArgTypes,
<br>- _ExistQOrParamVars, NotExistQOrParamVars),
<br>- NotExistQOrParamVars = [_ | _]
<br>- ->
<br>- % There should be no duplicate names to remove.
<br>- varset.coerce(VarSet, GenericVarSet),
<br>- NotExistQOrParamVarsStr =
<br>- mercury_vars_to_string(GenericVarSet, no, NotExistQOrParamVars),
<br>- Pieces = [words("Error: free type"),
<br>- words(choose_number(NotExistQOrParamVars,
<br>- "parameter", "parameters")),
<br>- words(NotExistQOrParamVarsStr),
<br>- words("in RHS of type definition."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
<br>- !:Specs = [Spec | !.Specs]
<br>- ;
<br>- % Check that all type variables in existential quantifiers do not
<br>- % occur in the head (maybe this should just be a warning, not an error?
<br>- % If we were to allow it, we would need to rename them apart.)
<br>-
<br>- set.list_to_set(ExistQVars, ExistQVarsSet),
<br>- set.list_to_set(Params, ParamsSet),
<br>- set.intersect(ExistQVarsSet, ParamsSet, ExistQParamsSet),
<br>- set.non_empty(ExistQParamsSet)
<br>- ->
<br>- % There should be no duplicate names to remove.
<br>- set.to_sorted_list(ExistQParamsSet, ExistQParams),
<br>- varset.coerce(VarSet, GenericVarSet),
<br>- ExistQParamVarsStr =
<br>- mercury_vars_to_string(GenericVarSet, no, ExistQParams),
<br>- Pieces = [words("Error:"),
<br>- words(choose_number(ExistQParams,
<br>- "type variable", "type variables")),
<br>- words(ExistQParamVarsStr),
<br>- words(choose_number(ExistQParams, "has", "have")),
<br>- words("overlapping scopes"),
<br>- words("(explicit type quantifier shadows argument type)."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
<br>- !:Specs = [Spec | !.Specs]
<br>- ;
<br>- % Check that all type variables in existential quantifiers occur
<br>- % somewhere in the constructor argument types or constraints.
<br>-
<br>- CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
<br>- type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
<br>- list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
<br>- constraint_list_get_tvars(Constraints, ConstraintTVars),
<br>- list.filter(list.contains(VarsInCtorArgTypes ++ ConstraintTVars),
<br>- ExistQVars, _OccursExistQVars, NotOccursExistQVars),
<br>- NotOccursExistQVars = [_ | _]
<br>- ->
<br>- % There should be no duplicate names to remove.
<br>- varset.coerce(VarSet, GenericVarSet),
<br>- NotOccursExistQVarsStr =
<br>- mercury_vars_to_string(GenericVarSet, no, NotOccursExistQVars),
<br>- Pieces = [words("Error:"),
<br>- words(choose_number(NotOccursExistQVars,
<br>- "type variable", "type variables")),
<br>- words(NotOccursExistQVarsStr),
<br>- words("in existential quantifier"),
<br>- words(choose_number(NotOccursExistQVars,
<br>- "does not occur", "do not occur")),
<br>- words("in arguments or constraints of constructor."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
<br>- !:Specs = [Spec | !.Specs]
<br>- ;
<br>- % Check that all type variables in existential constraints occur in
<br>- % the existential quantifiers.
<br>-
<br>- ConstraintArgTypeLists =
<br>- list.map(prog_constraint_get_arg_types, Constraints),
<br>- list.condense(ConstraintArgTypeLists, ConstraintArgTypes),
<br>- type_vars_list(ConstraintArgTypes, VarsInCtorArgTypes0),
<br>- list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
<br>- list.filter(list.contains(ExistQVars), VarsInCtorArgTypes,
<br>- _ExistQArgTypes, NotExistQArgTypes),
<br>- NotExistQArgTypes = [_ | _]
<br>- ->
<br>- varset.coerce(VarSet, GenericVarSet),
<br>- NotExistQArgTypesStr =
<br>- mercury_vars_to_string(GenericVarSet, no, NotExistQArgTypes),
<br>- Pieces = [words("Error:"),
<br>- words(choose_number(NotExistQArgTypes,
<br>- "type variable", "type variables")),
<br>- words(NotExistQArgTypesStr),
<br>- words("in class constraints,"),
<br>- words(choose_number(NotExistQArgTypes,
<br>- "which was", "which were")),
<br>- words("introduced with"), quote("=>"),
<br>- words("must be explicitly existentially quantified"),
<br>- words("using"), quote("some"), suffix("."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
<br>- !:Specs = [Spec | !.Specs]
<br>- ;
<br>- true
<br>- ),
<br>- process_du_ctors(Params, VarSet, BodyTerm, Ctors, !Specs).
<br>-
<br>-%-----------------------------------------------------------------------------%
<br>-
<br>- % parse_eqv_type_defn parses the definition of an equivalence type.
<br>- %
<br>-:- pred parse_eqv_type_defn(module_name::in, varset::in, term::in, term::in,
<br>- decl_attrs::in, condition::in, prog_context::in, int::in,
<br>- maybe1(item)::out) is det.
<br>-
<br>-parse_eqv_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes,
<br>- Condition, Context, SeqNum, MaybeItem) :-
<br>- parse_type_defn_head(ModuleName, VarSet, HeadTerm,
<br>- MaybeNameAndParams),
<br>- (
<br>- MaybeNameAndParams = error2(Specs),
<br>- MaybeItem = error1(Specs)
<br>- ;
<br>- MaybeNameAndParams = ok2(Name, Params),
<br>- % Check that all the variables in the body occur in the head.
<br>- (
<br>- term.contains_var(BodyTerm, Var),
<br>- term.coerce_var(Var, TVar),
<br>- not list.member(TVar, Params)
<br>- ->
<br>- BodyTermStr = describe_error_term(VarSet, BodyTerm),
<br>- Pieces = [words("Error: free type parameter"),
<br>- words("in RHS of type definition:"),
<br>- words(BodyTermStr), suffix("."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
<br>- MaybeItem = error1([Spec])
<br>- ;
<br>- % XXX Should pass more correct ContextPieces.
<br>- ContextPieces = [],
<br>- parse_type(BodyTerm, VarSet, ContextPieces, MaybeType),
<br>- (
<br>- MaybeType = ok1(Type),
<br>- varset.coerce(VarSet, TypeVarSet),
<br>- TypeDefn = parse_tree_eqv_type(Type),
<br>- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
<br>- TypeDefn, Condition, Context, SeqNum),
<br>- Item = item_type_defn(ItemTypeDefn),
<br>- MaybeItem0 = ok1(Item),
<br>- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
<br>- ;
<br>- MaybeType = error1(Specs),
<br>- MaybeItem = error1(Specs)
<br>- )
<br>- )
<br>- ).
<br>-
<br>-%-----------------------------------------------------------------------------%
<br>-
<br>- % parse_solver_type_defn parses the definition of a solver type.
<br>- %
<br>-:- pred parse_solver_type_defn(module_name::in, varset::in, term::in, term::in,
<br>- decl_attrs::in, condition::in, prog_context::in, int::in,
<br>- maybe1(item)::out) is det.
<br>-
<br>-parse_solver_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
<br>- Condition, Context, SeqNum, MaybeItem) :-
<br>- get_is_solver_type(IsSolverType, Attributes0, Attributes),
<br>- (
<br>- IsSolverType = non_solver_type,
<br>- Pieces = [words("Error: only solver types can be defined"),
<br>- words("by a `where' block alone."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
<br>- MaybeItem = error1([Spec])
<br>- ;
<br>- IsSolverType = solver_type,
<br>- MaybeWhere = parse_type_decl_where_term(solver_type, ModuleName,
<br>- VarSet, yes(BodyTerm)),
<br>- (
<br>- MaybeWhere = error2(Specs),
<br>- MaybeItem = error1(Specs)
<br>- ;
<br>- MaybeWhere = ok2(MaybeSolverTypeDetails, MaybeUserEqComp),
<br>- parse_solver_type_base(ModuleName, VarSet, HeadTerm,
<br>- MaybeSolverTypeDetails, MaybeUserEqComp, Attributes,
<br>- Condition, Context, SeqNum, MaybeItem)
<br>- )
<br>- ).
<br>-
<br>-:- pred parse_solver_type_base(module_name::in, varset::in, term::in,
<br>- maybe(solver_type_details)::in, maybe(unify_compare)::in,
<br>- decl_attrs::in, condition::in, prog_context::in, int::in,
<br>- maybe1(item)::out) is det.
<br>-
<br>-parse_solver_type_base(ModuleName, VarSet, HeadTerm,
<br>- MaybeSolverTypeDetails, MaybeUserEqComp, Attributes, Condition,
<br>- Context, SeqNum, MaybeItem) :-
<br>- (
<br>- MaybeSolverTypeDetails = yes(SolverTypeDetails),
<br>- parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeNameParams),
<br>- (
<br>- MaybeNameParams = error2(Specs),
<br>- MaybeItem = error1(Specs)
<br>- ;
<br>- MaybeNameParams = ok2(Name, Params),
<br>- (
<br>- RepnType = SolverTypeDetails ^ representation_type,
<br>- type_contains_var(RepnType, Var),
<br>- not list.member(Var, Params)
<br>- ->
<br>- HeadTermStr = describe_error_term(VarSet, HeadTerm),
<br>- Pieces = [words("Error: free type variable"),
<br>- words("in representation type:"),
<br>- words(HeadTermStr), suffix("."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(HeadTerm),
<br>- [always(Pieces)])]),
<br>- MaybeItem = error1([Spec])
<br>- ;
<br>- varset.coerce(VarSet, TypeVarSet),
<br>- TypeDefn = parse_tree_solver_type(SolverTypeDetails,
<br>- MaybeUserEqComp),
<br>- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
<br>- TypeDefn, Condition, Context, SeqNum),
<br>- Item = item_type_defn(ItemTypeDefn),
<br>- MaybeItem0 = ok1(Item),
<br>- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
<br>- )
<br>- )
<br>- ;
<br>- MaybeSolverTypeDetails = no,
<br>- Pieces = [words("Solver type with no solver_type_details."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
<br>- MaybeItem = error1([Spec])
<br>- ).
<br>-
<br>-%-----------------------------------------------------------------------------%
<br>-%
<br>-% Parse an abstract type definition.
<br>-%
<br>-
<br>-:- pred parse_abstract_type_defn(module_name::in, varset::in, term::in,
<br>- decl_attrs::in, condition::in, prog_context::in, int::in,
<br>- maybe1(item)::out) is det.
<br>-
<br>-parse_abstract_type_defn(ModuleName, VarSet, HeadTerm, Attributes0,
<br>- Condition, Context, SeqNum, MaybeItem) :-
<br>- parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeTypeCtorAndArgs),
<br>- get_is_solver_type(IsSolverType, Attributes0, Attributes),
<br>- (
<br>- MaybeTypeCtorAndArgs = error2(Specs),
<br>- MaybeItem = error1(Specs)
<br>- ;
<br>- MaybeTypeCtorAndArgs = ok2(Name, Params),
<br>- varset.coerce(VarSet, TypeVarSet),
<br>- TypeDefn = parse_tree_abstract_type(IsSolverType),
<br>- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params, TypeDefn,
<br>- Condition, Context, SeqNum),
<br>- Item = item_type_defn(ItemTypeDefn),
<br>- MaybeItem0 = ok1(Item),
<br>- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
<br>- ).
<br>-
<br>-%-----------------------------------------------------------------------------%
<br>-%
<br>-% Parse ... where ... clauses in type definitions. These clauses can specify
<br>-% type-specific unify and/or compare predicates for discriminated union types
<br>-% and solver type details for solver types.
<br>-%
<br>-
<br>- % The optional `where ...' part of the type definition syntax
<br>- % is a comma separated list of special type `attributes'.
<br>- %
<br>- % The possible attributes (in this order) are either
<br>- % - `type_is_abstract_noncanonical' on its own appears only in .int2
<br>- % files and indicates that the type has user-defined equality and/or
<br>- % comparison, but that what these predicates are is not known at
<br>- % this point
<br>- % or
<br>- % - `representation is <<type name>>' (required for solver types)
<br>- % - `initialisation is <<pred name>>' (required for solver types)
<br>- % - `ground is <<inst>>' (required for solver types)
<br>- % - `any is <<inst>>' (required for solver types)
<br>- % - `equality is <<pred name>>' (optional)
<br>- % - `comparison is <<pred name>>' (optional).
<br>- %
<br>-parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet,
<br>- Term, BeforeWhereTerm, MaybeWhereDetails) :-
<br>- (
<br>- Term = term.functor(term.atom("where"),
<br>- [BeforeWhereTermPrime, WhereTerm], _)
<br>- ->
<br>- BeforeWhereTerm = BeforeWhereTermPrime,
<br>- MaybeWhereDetails = parse_type_decl_where_term(IsSolverType,
<br>- ModuleName, VarSet, yes(WhereTerm))
<br>- ;
<br>- BeforeWhereTerm = Term,
<br>- MaybeWhereDetails = ok2(no, no)
<br>- ).
<br>-
<br>- % The maybe2 wrapper allows us to return an error code or a pair
<br>- % of results. Either result half may be empty, hence the maybe
<br>- % wrapper around each of those.
<br>- %
<br>-:- func parse_type_decl_where_term(is_solver_type, module_name, varset,
<br>- maybe(term)) = maybe2(maybe(solver_type_details), maybe(unify_compare)).
<br>-
<br>-parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) =
<br>- MaybeWhereDetails :-
<br>- (
<br>- MaybeTerm0 = no,
<br>- MaybeWhereDetails = ok2(no, no)
<br>- ;
<br>- MaybeTerm0 = yes(Term0),
<br>- some [!MaybeTerm] (
<br>- !:MaybeTerm = MaybeTerm0,
<br>- parse_where_attribute(parse_where_type_is_abstract_noncanonical,
<br>- MaybeTypeIsAbstractNoncanonical, !MaybeTerm),
<br>- parse_where_attribute(parse_where_is("representation",
<br>- parse_where_type_is(ModuleName, VarSet)),
<br>- MaybeRepresentationIs, !MaybeTerm),
<br>- parse_where_attribute(parse_where_initialisation_is(ModuleName,
<br>- VarSet),
<br>- MaybeInitialisationIs, !MaybeTerm),
<br>- parse_where_attribute(parse_where_is("ground",
<br>- parse_where_inst_is(ModuleName)),
<br>- MaybeGroundIs, !MaybeTerm),
<br>- parse_where_attribute(parse_where_is("any",
<br>- parse_where_inst_is(ModuleName)),
<br>- MaybeAnyIs, !MaybeTerm),
<br>- parse_where_attribute(parse_where_is("constraint_store",
<br>- parse_where_mutable_is(ModuleName)),
<br>- MaybeCStoreIs, !MaybeTerm),
<br>- parse_where_attribute(parse_where_is("equality",
<br>- parse_where_pred_is(ModuleName, VarSet)),
<br>- MaybeEqualityIs, !MaybeTerm),
<br>- parse_where_attribute(parse_where_is("comparison",
<br>- parse_where_pred_is(ModuleName, VarSet)),
<br>- MaybeComparisonIs, !MaybeTerm),
<br>- parse_where_end(!.MaybeTerm, MaybeWhereEnd)
<br>- ),
<br>- MaybeWhereDetails = make_maybe_where_details(
<br>- IsSolverType,
<br>- MaybeTypeIsAbstractNoncanonical,
<br>- MaybeRepresentationIs,
<br>- MaybeInitialisationIs,
<br>- MaybeGroundIs,
<br>- MaybeAnyIs,
<br>- MaybeCStoreIs,
<br>- MaybeEqualityIs,
<br>- MaybeComparisonIs,
<br>- MaybeWhereEnd,
<br>- Term0
<br>- )
<br>- ).
<br>-
<br>- % parse_where_attribute(Parser, Result, MaybeTerm, MaybeTailTerm)
<br>- % handles
<br>- % - where MaybeTerm may contain nothing
<br>- % - where MaybeTerm may be a comma-separated pair
<br>- % - applies Parser to the appropriate (sub)term to obtain Result
<br>- % - sets MaybeTailTerm depending upon whether the Result is an error
<br>- % or not and whether there is more to parse because MaybeTerm
<br>- % was a comma-separated pair.
<br>- %
<br>-:- pred parse_where_attribute((func(term) = maybe1(maybe(T)))::in,
<br>- maybe1(maybe(T))::out, maybe(term)::in, maybe(term)::out) is det.
<br>-
<br>-parse_where_attribute(Parser, Result, MaybeTerm, MaybeTailTerm) :-
<br>- (
<br>- MaybeTerm = no,
<br>- MaybeTailTerm = no,
<br>- Result = ok1(no)
<br>- ;
<br>- MaybeTerm = yes(Term),
<br>- (
<br>- Term = term.functor(term.atom(","), [HeadTerm, TailTerm], _)
<br>- ->
<br>- Result = Parser(HeadTerm),
<br>- MaybeTailTermIfYes = yes(TailTerm)
<br>- ;
<br>- Result = Parser(Term),
<br>- MaybeTailTermIfYes = no
<br>- ),
<br>- (
<br>- Result = error1(_),
<br>- MaybeTailTerm = no
<br>- ;
<br>- Result = ok1(no),
<br>- MaybeTailTerm = yes(Term)
<br>- ;
<br>- Result = ok1(yes(_)),
<br>- MaybeTailTerm = MaybeTailTermIfYes
<br>- )
<br>- ).
<br>-
<br>- % Parser for `where ...' attributes of the form
<br>- % `attributename is attributevalue'.
<br>- %
<br>-:- func parse_where_is(string, func(term) = maybe1(T), term) =
<br>- maybe1(maybe(T)).
<br>-
<br>-parse_where_is(Name, Parser, Term) = Result :-
<br>- ( Term = term.functor(term.atom("is"), [LHS, RHS], _) ->
<br>- ( LHS = term.functor(term.atom(Name), [], _) ->
<br>- RHSResult = Parser(RHS),
<br>- (
<br>- RHSResult = ok1(ParsedRHS),
<br>- Result = ok1(yes(ParsedRHS))
<br>- ;
<br>- RHSResult = error1(Specs),
<br>- Result = error1(Specs)
<br>- )
<br>- ;
<br>- Result = ok1(no)
<br>- )
<br>- ;
<br>- Pieces = [words("Error: expected"), quote("is"), suffix("."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(Term), [always(Pieces)])]),
<br>- Result = error1([Spec])
<br>- ).
<br>-
<br>-:- func parse_where_type_is_abstract_noncanonical(term) = maybe1(maybe(unit)).
<br>-
<br>-parse_where_type_is_abstract_noncanonical(Term) =
<br>- ( Term = term.functor(term.atom("type_is_abstract_noncanonical"), [], _) ->
<br>- ok1(yes(unit))
<br>- ;
<br>- ok1(no)
<br>- ).
<br>-
<br>-:- func parse_where_initialisation_is(module_name, varset, term) =
<br>- maybe1(maybe(sym_name)).
<br>-
<br>-parse_where_initialisation_is(ModuleName, VarSet, Term) = Result :-
<br>- Result0 = parse_where_is("initialisation",
<br>- parse_where_pred_is(ModuleName, VarSet), Term),
<br>- (
<br>- Result0 = ok1(no)
<br>- ->
<br>- Result1 = parse_where_is("initialization",
<br>- parse_where_pred_is(ModuleName, VarSet), Term)
<br>- ;
<br>- Result1 = Result0
<br>- ),
<br>- promise_pure (
<br>- (
<br>- Result1 = ok1(yes(_)),
<br>- semipure
<br>- semipure_get_solver_auto_init_supported(AutoInitSupported),
<br>- (
<br>- AutoInitSupported = yes,
<br>- Result = Result1
<br>- ;
<br>- AutoInitSupported = no,
<br>- Pieces = [words("Error: unknown attribute"),
<br>- words("in solver type definition."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(Term), [always(Pieces)])]),
<br>- Result = error1([Spec])
<br>- )
<br>- ;
<br>- ( Result1 = ok1(no)
<br>- ; Result1 = error1(_)
<br>- ),
<br>- Result = Result1
<br>- )
<br>- ).
<br>-
<br>-:- func parse_where_pred_is(module_name, varset, term) = maybe1(sym_name).
<br>-
<br>-parse_where_pred_is(ModuleName, VarSet, Term) = MaybeSymName :-
<br>- parse_implicitly_qualified_symbol_name(ModuleName, VarSet, Term,
<br>- MaybeSymName).
<br>-
<br>-:- func parse_where_inst_is(module_name, term) = maybe1(mer_inst).
<br>-
<br>-parse_where_inst_is(_ModuleName, Term) = MaybeInst :-
<br>- (
<br>- convert_inst(no_allow_constrained_inst_var, Term, Inst),
<br>- not inst_contains_unconstrained_var(Inst)
<br>- ->
<br>- MaybeInst = ok1(Inst)
<br>- ;
<br>- Pieces = [words("Error: expected a ground, unconstrained inst."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(Term), [always(Pieces)])]),
<br>- MaybeInst = error1([Spec])
<br>- ).
<br>-
<br>-:- func parse_where_type_is(module_name, varset, term) = maybe1(mer_type).
<br>-
<br>-parse_where_type_is(_ModuleName, VarSet, Term) = MaybeType :-
<br>- % XXX We should pass meaningful ContextPieces.
<br>- ContextPieces = [],
<br>- parse_type(Term, VarSet, ContextPieces, MaybeType).
<br>-
<br>-:- func parse_where_mutable_is(module_name, term) = maybe1(list(item)).
<br>-
<br>-parse_where_mutable_is(ModuleName, Term) = MaybeItems :-
<br>- ( Term = term.functor(term.atom("mutable"), _, _) ->
<br>- parse_mutable_decl_term(ModuleName, Term, MaybeItem),
<br>- (
<br>- MaybeItem = ok1(Mutable),
<br>- MaybeItems = ok1([Mutable])
<br>- ;
<br>- MaybeItem = error1(Specs),
<br>- MaybeItems = error1(Specs)
<br>- )
<br>- ; list_term_to_term_list(Term, Terms) ->
<br>- map_parser(parse_mutable_decl_term(ModuleName), Terms, MaybeItems)
<br>- ;
<br>- Pieces = [words("Error: expected a mutable declaration"),
<br>- words("or a list of mutable declarations."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(Term), [always(Pieces)])]),
<br>- MaybeItems = error1([Spec])
<br>- ).
<br>-
<br>-:- pred parse_mutable_decl_term(module_name::in, term::in, maybe1(item)::out)
<br>- is det.
<br>-
<br>-parse_mutable_decl_term(ModuleName, Term, MaybeItem) :-
<br>- (
<br>- Term = term.functor(term.atom("mutable"), Args, Context),
<br>- varset.init(VarSet),
<br>- parse_mutable_decl(ModuleName, VarSet, Args, Context, -1,
<br>- MaybeItemPrime)
<br>- ->
<br>- MaybeItem = MaybeItemPrime
<br>- ;
<br>- Pieces = [words("Error: expected a mutable declaration."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(Term), [always(Pieces)])]),
<br>- MaybeItem = error1([Spec])
<br>- ).
<br>-
<br>-:- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det.
<br>-
<br>-parse_where_end(no, ok1(yes(unit))).
<br>-parse_where_end(yes(Term), error1([Spec])) :-
<br>- Pieces = [words("Error: attributes are either badly ordered"),
<br>- words("or contain an unrecognised attribute."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(Term), [always(Pieces)])]).
<br>-
<br>-:- func make_maybe_where_details(is_solver_type, maybe1(maybe(unit)),
<br>- maybe1(maybe(mer_type)), maybe1(maybe(init_pred)),
<br>- maybe1(maybe(mer_inst)), maybe1(maybe(mer_inst)),
<br>- maybe1(maybe(list(item))),
<br>- maybe1(maybe(equality_pred)), maybe1(maybe(comparison_pred)),
<br>- maybe1(maybe(unit)), term)
<br>- = maybe2(maybe(solver_type_details), maybe(unify_compare)).
<br>-
<br>-make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical,
<br>- MaybeRepresentationIs, MaybeInitialisationIs,
<br>- MaybeGroundIs, MaybeAnyIs, MaybeCStoreIs,
<br>- MaybeEqualityIs, MaybeComparisonIs, MaybeWhereEnd, WhereTerm)
<br>- = MaybeSolverUC :-
<br>- (
<br>- MaybeTypeIsAbstractNoncanonical = ok1(TypeIsAbstractNoncanonical),
<br>- MaybeRepresentationIs = ok1(RepresentationIs),
<br>- MaybeInitialisationIs = ok1(InitialisationIs),
<br>- MaybeGroundIs = ok1(GroundIs),
<br>- MaybeAnyIs = ok1(AnyIs),
<br>- MaybeCStoreIs = ok1(CStoreIs),
<br>- MaybeEqualityIs = ok1(EqualityIs),
<br>- MaybeComparisonIs = ok1(ComparisonIs),
<br>- MaybeWhereEnd = ok1(WhereEnd)
<br>- ->
<br>- MaybeSolverUC = make_maybe_where_details_2(IsSolverType,
<br>- TypeIsAbstractNoncanonical, RepresentationIs, InitialisationIs,
<br>- GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs,
<br>- WhereEnd, WhereTerm)
<br>- ;
<br>- Specs =
<br>- get_any_errors1(MaybeTypeIsAbstractNoncanonical) ++
<br>- get_any_errors1(MaybeRepresentationIs) ++
<br>- get_any_errors1(MaybeInitialisationIs) ++
<br>- get_any_errors1(MaybeGroundIs) ++
<br>- get_any_errors1(MaybeAnyIs) ++
<br>- get_any_errors1(MaybeCStoreIs) ++
<br>- get_any_errors1(MaybeEqualityIs) ++
<br>- get_any_errors1(MaybeComparisonIs) ++
<br>- get_any_errors1(MaybeWhereEnd),
<br>- MaybeSolverUC = error2(Specs)
<br>- ).
<br>-
<br>-:- func make_maybe_where_details_2(is_solver_type, maybe(unit),
<br>- maybe(mer_type), maybe(init_pred), maybe(mer_inst), maybe(mer_inst),
<br>- maybe(list(item)), maybe(equality_pred), maybe(comparison_pred),
<br>- maybe(unit), term)
<br>- = maybe2(maybe(solver_type_details), maybe(unify_compare)).
<br>-
<br>-make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
<br>- RepresentationIs, InitialisationIs, GroundIs, AnyIs, CStoreIs,
<br>- EqualityIs, ComparisonIs, _WhereEnd, WhereTerm) = MaybeSolverUC :-
<br>- (
<br>- TypeIsAbstractNoncanonical = yes(_),
<br>- % rafe: XXX I think this is wrong. There isn't a problem with having
<br>- % the solver_type_details and type_is_abstract_noncanonical.
<br>- (
<br>- RepresentationIs = maybe.no,
<br>- InitialisationIs = maybe.no,
<br>- GroundIs = maybe.no,
<br>- AnyIs = maybe.no,
<br>- EqualityIs = maybe.no,
<br>- ComparisonIs = maybe.no,
<br>- CStoreIs = maybe.no
<br>- ->
<br>- MaybeSolverUC =
<br>- ok2(no, yes(abstract_noncanonical_type(IsSolverType)))
<br>- ;
<br>- Pieces = [words("Error:"),
<br>- quote("where type_is_abstract_noncanonical"),
<br>- words("excludes other"), quote("where ..."),
<br>- words("attributes."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(WhereTerm), [always(Pieces)])]),
<br>- MaybeSolverUC = error2([Spec])
<br>- )
<br>- ;
<br>- TypeIsAbstractNoncanonical = maybe.no,
<br>- (
<br>- IsSolverType = solver_type,
<br>- (
<br>- RepresentationIs = yes(RepnType),
<br>- InitialisationIs = MaybeInitialisation,
<br>- GroundIs = MaybeGroundInst,
<br>- AnyIs = MaybeAnyInst,
<br>- EqualityIs = MaybeEqPred,
<br>- ComparisonIs = MaybeCmpPred,
<br>- CStoreIs = MaybeMutableItems
<br>- ->
<br>- (
<br>- MaybeGroundInst = yes(GroundInst)
<br>- ;
<br>- MaybeGroundInst = no,
<br>- GroundInst = ground_inst
<br>- ),
<br>- (
<br>- MaybeAnyInst = yes(AnyInst)
<br>- ;
<br>- MaybeAnyInst = no,
<br>- AnyInst = ground_inst
<br>- ),
<br>- (
<br>- MaybeMutableItems = yes(MutableItems)
<br>- ;
<br>- MaybeMutableItems = no,
<br>- MutableItems = []
<br>- ),
<br>- (
<br>- MaybeInitialisation = yes(InitPred),
<br>- HowToInit = solver_init_automatic(InitPred)
<br>- ;
<br>- MaybeInitialisation = no,
<br>- HowToInit = solver_init_explicit
<br>- ),
<br>- SolverTypeDetails = solver_type_details(
<br>- RepnType, HowToInit, GroundInst, AnyInst, MutableItems),
<br>- MaybeSolverTypeDetails = yes(SolverTypeDetails),
<br>- (
<br>- MaybeEqPred = no,
<br>- MaybeCmpPred = no
<br>- ->
<br>- MaybeUnifyCompare = no
<br>- ;
<br>- MaybeUnifyCompare = yes(unify_compare(
<br>- MaybeEqPred, MaybeCmpPred))
<br>- ),
<br>- MaybeSolverUC = ok2(MaybeSolverTypeDetails, MaybeUnifyCompare)
<br>- ;
<br>- RepresentationIs = no
<br>- ->
<br>- Pieces = [words("Error: solver type definitions must have a"),
<br>- quote("representation"), words("attribute."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(WhereTerm),
<br>- [always(Pieces)])]),
<br>- MaybeSolverUC = error2([Spec])
<br>- ;
<br>- unexpected(this_file, "make_maybe_where_details_2: " ++
<br>- "shouldn't have reached this point! (1)")
<br>- )
<br>- ;
<br>- IsSolverType = non_solver_type,
<br>- (
<br>- ( RepresentationIs = yes(_)
<br>- ; InitialisationIs = yes(_)
<br>- ; GroundIs = yes(_)
<br>- ; AnyIs = yes(_)
<br>- ; CStoreIs = yes(_)
<br>- )
<br>- ->
<br>- Pieces = [words("Error: solver type attribute given"),
<br>- words("for non-solver type."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(get_term_context(WhereTerm),
<br>- [always(Pieces)])]),
<br>- MaybeSolverUC = error2([Spec])
<br>- ;
<br>- EqualityIs = MaybeEqPred,
<br>- ComparisonIs = MaybeCmpPred,
<br>- MaybeSolverUC =
<br>- ok2(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred)))
<br>- )
<br>- )
<br>- ).
<br>-
<br>-%-----------------------------------------------------------------------------%
<br>-%
<br>-% Predicates useful for parsing several kinds of type definitions.
<br>-%
<br>-
<br>-parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeTypeCtorAndArgs) :-
<br>- (
<br>- HeadTerm = term.variable(_, Context),
<br>- Pieces = [words("Error: variable on LHS of type definition."), nl],
<br>- Spec = error_spec(severity_error, phase_term_to_parse_tree,
<br>- [simple_msg(Context, [always(Pieces)])]),
<br>- MaybeTypeCtorAndArgs = error2([Spec])
<br>- ;
<br>- HeadTerm = term.functor(_, _, HeadContext),
<br>- ContextPieces = [words("In type definition:")],
<br>- parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
<br>- VarSet, ContextPieces, HeadResult),
<br>- (
<br>- HeadResult = error2(Specs),
<br>- MaybeTypeCtorAndArgs = error2(Specs)
<br>- ;
<br>- HeadResult = ok2(Name, ArgTerms),
<br>- % Check that all the head args are variables.
<br>- ( term_list_to_var_list(ArgTerms, Params0) ->
<br>- % Check that all the head arg variables are distinct.
<br>- &n