[m-rev.] diff: add a copy of the current term parse modules to the extras
Julien Fischer
jfischer at opturion.com
Wed Mar 15 15:51:48 AEDT 2017
Add a copy of the current term parser modules to the extras.
Upcoming changes to the standard library required to support additional
builtin integer types will not be backwards compatible; the copy of
these modules in extras can be used by existing code code until it is
ready to be updated.
extras/old_term_parser/old_lexer.m:
extras/old_term_parser/old_parser.m:
extras/old_term_parser/old_term.m:
extras/old_term_parser/old_term_io.m:
extras/old_term_parser/old_varset.m:
Renamed versions of the corresponding standard library modules.
extras/old_term_parser/old_term_parser.m:
Add a top-level package for the above modules.
extras/old_term_parser/Makefile:
extras/old_term_parser/Mercury.options:
Add the necessary build rules.
extras/README:
Document the addition.
Julien.
diff --git a/extras/README b/extras/README
index 1802309..e4e50a8 100644
--- a/extras/README
+++ b/extras/README
@@ -71,6 +71,12 @@ net A network library which uses the standard library stream
odbc A Mercury interface to ODBC (Open Database Connectivity),
for interfacing to standard relational database packages.
+
+old_term_parser A library containing versions of the the standard library's
+ lexer, parser, term, term_io and varset modules as they
+ were on 2017-02-15. Intended for backwards compatibility
+ with older code.
+
posix A Mercury interface to some of the POSIX
(Portable Operating System Interface) APIs.
diff --git a/extras/old_term_parser/Makefile b/extras/old_term_parser/Makefile
index e69de29..a6a8f59 100644
--- a/extras/old_term_parser/Makefile
+++ b/extras/old_term_parser/Makefile
@@ -0,0 +1,24 @@
+#-----------------------------------------------------------------------------#
+# vim: ts=8 sw=8 noexpandtab
+#-----------------------------------------------------------------------------#
+# Copyright (C) 2017 The Mercury team.
+# This file may only be copied under the terms of the GNU Library General
+# Public License - see the file COPYING.LIB in the Mercury distribution.
+#-----------------------------------------------------------------------------#
+
+# Build the old term parser library using mmc --make.
+
+TARGET=old_term_parser
+
+.PHONY: build
+build:
+ mmc --make lib$(TARGET)
+
+.PHONY: install
+install:
+ mmc --make lib$(TARGET).install
+
+.PHONY: realclean
+realclean:
+ mmc --make $(TARGET).realclean
+ /bin/rm -rf Mercury
diff --git a/extras/old_term_parser/old_lexer.m b/extras/old_term_parser/old_lexer.m
index e69de29..7aabc67 100644
--- a/extras/old_term_parser/old_lexer.m
+++ b/extras/old_term_parser/old_lexer.m
@@ -0,0 +1,3051 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+% Copyright (C) 1993-2000, 2003-2008, 2011-2012 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% File: old_lexer.m.
+% Main author: fjh.
+% Stability: high.
+%
+% Lexical analysis. This module defines the representation of tokens
+% and exports predicates for reading in tokens from an input stream.
+%
+% See ISO Prolog 6.4. Also see the comments at the top of parser.m.
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module old_lexer.
+:- interface.
+
+:- import_module char.
+:- import_module io.
+:- import_module integer.
+
+%---------------------------------------------------------------------------%
+
+:- type token
+ ---> name(string)
+ ; variable(string)
+ ; integer(int)
+
+ ; big_integer(integer_base, integer)
+ % An integer that is too big for `int'.
+
+ ; float(float)
+ ; string(string) % "...."
+ ; implementation_defined(string) % $name
+ ; open % '('
+ ; open_ct % '(' without any preceding whitespace
+ ; close % ')'
+ ; open_list % '['
+ ; close_list % ']'
+ ; open_curly % '{'
+ ; close_curly % '}'
+ ; ht_sep % '|'
+ ; comma % ','
+ ; end % '.'
+ ; junk(char) % junk character in the input stream
+ ; error(string) % some other invalid token
+ ; io_error(io.error) % error reading from the input stream
+ ; eof % end-of-file
+
+ ; integer_dot(int).
+ % The lexer will never return integer_dot. This token is used
+ % internally in the lexer, to keep the grammar LL(1) so that
+ % only one character of pushback is needed. But the lexer will
+ % convert integer_dot/1 tokens to integer/1 tokens before
+ % returning them.
+
+:- type integer_base
+ ---> base_2
+ ; base_8
+ ; base_10
+ ; base_16.
+
+ % For every token, we record the line number of the line on
+ % which the token occurred.
+ %
+:- type token_context == int. % line number
+
+ % This "fat list" representation is more efficient than a list of pairs.
+ %
+:- type token_list
+ ---> token_cons(token, token_context, token_list)
+ ; token_nil.
+
+ % Read a list of tokens either from the current input stream
+ % or from the specified input stream.
+ % Keep reading until we encounter either an `end' token
+ % (i.e. a full stop followed by whitespace) or the end-of-file.
+ %
+:- pred get_token_list(token_list::out, io::di, io::uo) is det.
+:- pred get_token_list(io.text_input_stream::in, token_list::out,
+ io::di, io::uo) is det.
+
+ % The type `offset' represents a (zero-based) offset into a string.
+ %
+:- type offset == int.
+
+ % string_get_token_list_max(String, MaxOffset, Tokens,
+ % InitialPos, FinalPos):
+ %
+ % Scan a list of tokens from a string, starting at the current offset
+ % specified by InitialPos. Keep scanning until either we encounter either
+ % an `end' token (i.e. a full stop followed by whitespace) or until we
+ % reach MaxOffset. (MaxOffset must be =< the length of the string.)
+ % Return the tokens scanned in Tokens, and return the position one
+ % character past the end of the last token in FinalPos.
+ %
+:- pred string_get_token_list_max(string::in, offset::in, token_list::out,
+ posn::in, posn::out) is det.
+
+ % string_get_token_list(String, Tokens, InitialPos, FinalPos):
+ %
+ % calls string_get_token_list_max above with MaxPos = length of String.
+ %
+:- pred string_get_token_list(string::in, token_list::out,
+ posn::in, posn::out) is det.
+
+ % Convert a token to a human-readable string describing the token.
+ %
+:- pred token_to_string(token::in, string::out) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+:- implementation.
+%---------------------------------------------------------------------------%
+
+:- interface.
+
+ % graphic_token_char(Char): true iff `Char'
+ % is "graphic token char" (ISO Prolog 6.4.2).
+ % This is exported for use by term_io.quote_atom.
+ %
+:- pred graphic_token_char(char::in) is semidet.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+:- import_module require.
+:- import_module string.
+
+% Note that there are two implementations of most predicates here:
+% one that deals with strings, and another that deals with io.states.
+% We can't write the io.state version in terms of the string version
+% because we don't know how much string to slurp up until after we have
+% lexically analysed it. Some interactive applications require the old
+% Prolog behaviour of stopping after an end token (i.e. `.' plus whitespace)
+% rather than reading in whole lines. Conversely, we can't write the string
+% version using the io.state version, since that would require either
+% cheating with the io.state or ruining the string interface.
+%
+% An alternative would be to write both versions in terms of a generic
+% "char_stream" typeclass, with instances for io.states and for strings.
+% However, for this to be acceptably efficient it would require the compiler
+% to specialize the code, which currently (13 May 98) it is not capable
+% of doing.
+%
+% In fact, the string version is still not as efficient as I would like.
+% The compiler ought to (but currently doesn't) unfold all the instances
+% of the `posn' type. We could do this type unfolding by hand, but
+% it would be very tedious and it would make the code less readable.
+% If and when there is compiler support for this, we should also think about
+% moving the `String' and `Len' arguments into the posn (or making a new
+% `lexer_state' struct which contains both the posn and the String and Len
+% arguments).
+
+get_token_list(Tokens, !IO) :-
+ io.input_stream(Stream, !IO),
+ get_token_list(Stream, Tokens, !IO).
+
+get_token_list(Stream, Tokens, !IO) :-
+ % We build the tokens up as lists of characters in reverse order.
+ % When we get to the end of each token, we call `rev_char_list_to_string/2'
+ % to convert that representation into a string.
+ %
+ % Comments of the form
+ % foo --> bar . baz
+ % mean that we are parsing a `foo', and we've already scanned past
+ % the `bar', so now we need to match with a `baz'.
+ get_token(Stream, Token, Context, !IO),
+ get_token_list_2(Stream, Token, Context, Tokens, !IO).
+
+:- pred get_token_list_2(io.input_stream::in, token::in, token_context::in,
+ token_list::out, io::di, io::uo) is det.
+
+get_token_list_2(Stream, Token0, Context0, Tokens, !IO) :-
+ (
+ Token0 = eof,
+ Tokens = token_nil
+ ;
+ ( Token0 = end
+ ; Token0 = error(_)
+ ; Token0 = io_error(_)
+ ),
+ Tokens = token_cons(Token0, Context0, token_nil)
+ ;
+ Token0 = integer_dot(Int),
+ get_context(Stream, Context1, !IO),
+ get_dot(Stream, Token1, !IO),
+ get_token_list_2(Stream, Token1, Context1, Tokens1, !IO),
+ Tokens = token_cons(integer(Int), Context0, Tokens1)
+ ;
+ ( Token0 = float(_)
+ ; Token0 = string(_)
+ ; Token0 = variable(_)
+ ; Token0 = integer(_)
+ ; Token0 = big_integer(_, _)
+ ; Token0 = implementation_defined(_)
+ ; Token0 = junk(_)
+ ; Token0 = name(_)
+ ; Token0 = open
+ ; Token0 = open_ct
+ ; Token0 = close
+ ; Token0 = open_list
+ ; Token0 = close_list
+ ; Token0 = open_curly
+ ; Token0 = close_curly
+ ; Token0 = comma
+ ; Token0 = ht_sep
+ ),
+ get_token(Stream, Token1, Context1, !IO),
+ get_token_list_2(Stream, Token1, Context1, Tokens1, !IO),
+ Tokens = token_cons(Token0, Context0, Tokens1)
+ ).
+
+string_get_token_list_max(String, Len, Tokens, !Posn) :-
+ string_get_token(String, Len, Token, Context, !Posn),
+ (
+ Token = eof,
+ Tokens = token_nil
+ ;
+ ( Token = end
+ ; Token = error(_)
+ ; Token = io_error(_)
+ ),
+ Tokens = token_cons(Token, Context, token_nil)
+ ;
+ ( Token = float(_)
+ ; Token = string(_)
+ ; Token = variable(_)
+ ; Token = integer(_)
+ ; Token = big_integer(_, _)
+ ; Token = integer_dot(_)
+ ; Token = implementation_defined(_)
+ ; Token = junk(_)
+ ; Token = name(_)
+ ; Token = open
+ ; Token = open_ct
+ ; Token = close
+ ; Token = open_list
+ ; Token = close_list
+ ; Token = open_curly
+ ; Token = close_curly
+ ; Token = comma
+ ; Token = ht_sep
+ ),
+ Tokens = token_cons(Token, Context, Tokens1),
+ string_get_token_list_max(String, Len, Tokens1, !Posn)
+ ).
+
+string_get_token_list(String, Tokens, !Posn) :-
+ string.length(String, Len),
+ string_get_token_list_max(String, Len, Tokens, !Posn).
+
+%---------------------------------------------------------------------------%
+%
+% Some low-level routines.
+%
+
+:- pred get_context(io.input_stream::in, token_context::out, io::di, io::uo)
+ is det.
+
+get_context(Stream, Context, !IO) :-
+ io.get_line_number(Stream, Context, !IO).
+
+:- type string_token_context == token_context.
+
+:- pred string_get_context(posn::in, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_context(StartPosn, Context, !Posn) :-
+ StartPosn = posn(StartLineNum, _, _),
+ Context = StartLineNum.
+ % In future, we might want to modify this code to read something like this:
+ %
+ % posn_to_line_and_column(StartPosn, StartLineNum, StartColumn),
+ % posn_to_line_and_column(!.Posn, EndLineNum, EndColumn),
+ % Context = detailed(StartLine, StartColumn, EndLine, EndColumn).
+
+:- pred string_read_char(string::in, int::in, char::out,
+ posn::in, posn::out) is semidet.
+:- pragma inline(string_read_char/5).
+
+string_read_char(String, Len, Char, Posn0, Posn) :-
+ Posn0 = posn(LineNum0, LineOffset0, Offset0),
+ Offset0 < Len,
+ string.unsafe_index_next(String, Offset0, Offset, Char),
+ ( if Char = '\n' then
+ LineNum = LineNum0 + 1,
+ Posn = posn(LineNum, Offset, Offset)
+ else
+ Posn = posn(LineNum0, LineOffset0, Offset)
+ ).
+
+:- pred string_ungetchar(string::in, posn::in, posn::out) is det.
+
+string_ungetchar(String, Posn0, Posn) :-
+ Posn0 = posn(LineNum0, LineOffset0, Offset0),
+ ( if string.unsafe_prev_index(String, Offset0, Offset, Char) then
+ ( if Char = '\n' then
+ LineNum = LineNum0 - 1,
+ Posn = posn(LineNum, Offset, Offset)
+ else
+ Posn = posn(LineNum0, LineOffset0, Offset)
+ )
+ else
+ Posn = Posn0
+ ).
+
+:- pred grab_string(string::in, posn::in, string::out,
+ posn::in, posn::out) is det.
+
+grab_string(String, Posn0, SubString, Posn, Posn) :-
+ Posn0 = posn(_, _, Offset0),
+ Posn = posn(_, _, Offset),
+ string.unsafe_between(String, Offset0, Offset, SubString).
+
+ % As above, but the string is known to represent a float literal.
+ % Filter out any underscore characters from the returned string.
+ % We have to do this since the underlying mechanisms we currently use for
+ % converting strings into floats (sscanf in C, parseDouble in Java etc)
+ % cannot handle underscores in their input.
+ %
+:- pred grab_float_string(string::in, posn::in, string::out,
+ posn::in, posn::out) is det.
+
+grab_float_string(String, Posn0, FloatString, Posn, Posn) :-
+ Posn0 = posn(_, _, Offset0),
+ Posn = posn(_, _, Offset),
+ unsafe_get_float_between(String, Offset0, Offset, FloatString).
+
+:- pred unsafe_get_float_between(string::in, int::in, int::in,
+ string::uo) is det.
+:- pragma foreign_proc("C",
+ unsafe_get_float_between(Str::in, Start::in, End::in, FloatStr::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness, no_sharing],
+"
+ int src;
+ int dst = 0;
+
+ MR_allocate_aligned_string_msg(FloatStr, End - Start, MR_ALLOC_ID);
+ for (src = Start; src < End; src++) {
+ if (Str[src] != '_') {
+ FloatStr[dst] = Str[src];
+ dst++;
+ }
+ }
+ FloatStr[dst] = '\\0';
+").
+
+:- pragma foreign_proc("C#",
+ unsafe_get_float_between(Str::in, Start::in, End::in, SubString::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SubString = Str.Substring(Start, End - Start).Replace(\"_\", \"\");
+").
+
+:- pragma foreign_proc("Java",
+ unsafe_get_float_between(Str::in, Start::in, End::in, FloatStr::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ FloatStr = Str.substring(Start, End).replace(\"_\", \"\");
+").
+
+ % For use by the Erlang backend.
+ %
+unsafe_get_float_between(Str, Start, End, FloatStr) :-
+ string.unsafe_between(Str, Start, End, FloatStr0),
+ ( if string.contains_char(FloatStr0, '_') then
+ string.to_char_list(FloatStr0, Digits0),
+ list.negated_filter(is_underscore, Digits0, Digits),
+ string.from_char_list(Digits, FloatStr)
+ else
+ FloatStr = FloatStr0
+ ).
+
+:- pred is_underscore(char::in) is semidet.
+
+is_underscore('_').
+
+:- pred string_set_line_number(int::in, posn::in, posn::out) is det.
+
+string_set_line_number(LineNumber, Posn0, Posn) :-
+ Posn0 = posn(_, _, Offset),
+ Posn = posn(LineNumber, Offset, Offset).
+
+%---------------------------------------------------------------------------%
+
+:- type get_token_action
+ ---> action_whitespace
+ ; action_alpha_lower
+ ; action_alpha_upper_uscore
+ ; action_zero
+ ; action_nonzero_digit
+ ; action_special_token
+ ; action_dot
+ ; action_percent
+ ; action_quote
+ ; action_slash
+ ; action_hash
+ ; action_backquote
+ ; action_dollar
+ ; action_graphic_token.
+
+:- type scanned_past_whitespace
+ ---> scanned_past_whitespace
+ ; not_scanned_past_whitespace.
+
+:- pred get_token(io.input_stream::in, token::out, token_context::out,
+ io::di, io::uo) is det.
+
+get_token(Stream, Token, Context, !IO) :-
+ get_token_2(Stream, not_scanned_past_whitespace, Token, Context, !IO).
+
+ % If passed `scanned_past_whitespace' then we have already scanned past
+ % some whitespace, so '(' gets scanned as `open' rather than `open_ct'.
+ %
+ % `get_token_2' must be inlined into `execute_get_token_action' so that
+ % the recursive call can be compiled to a loop on backends that cannot
+ % eliminate tail calls in general.
+ %
+:- pragma inline(get_token_2/6).
+:- pred get_token_2(io.input_stream::in, scanned_past_whitespace::in,
+ token::out, token_context::out, io::di, io::uo) is det.
+
+get_token_2(Stream, ScannedPastWhiteSpace, Token, Context, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ get_context(Stream, Context, !IO),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ get_context(Stream, Context, !IO),
+ Token = eof
+ ;
+ Result = ok,
+ ( if lookup_token_action(Char, Action) then
+ execute_get_token_action(Stream, Char, Action,
+ ScannedPastWhiteSpace, Token, Context, !IO)
+ else
+ get_context(Stream, Context, !IO),
+ Token = junk(Char)
+ )
+ ).
+
+:- pred string_get_token(string::in, int::in, token::out,
+ token_context::out, posn::in, posn::out) is det.
+
+string_get_token(String, Len, Token, Context, !Posn) :-
+ string_get_token_2(String, Len, not_scanned_past_whitespace,
+ Token, Context, !Posn).
+
+:- pragma inline(string_get_token_2/7). % see get_token_2
+:- pred string_get_token_2(string::in, int::in, scanned_past_whitespace::in,
+ token::out, token_context::out, posn::in, posn::out) is det.
+
+string_get_token_2(String, Len, ScannedPastWhiteSpace, Token, Context, !Posn)
+ :-
+ Posn0 = !.Posn,
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if lookup_token_action(Char, Action) then
+ execute_string_get_token_action(String, Len, Posn0, Char, Action,
+ ScannedPastWhiteSpace, Token, Context, !Posn)
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = junk(Char)
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = eof
+ ).
+
+ % Decide on how the given character should be treated. Note that
+ % performance suffers significantly if this predicate is not inlined.
+ %
+:- pred lookup_token_action(char::in, get_token_action::out) is semidet.
+:- pragma inline(lookup_token_action/2).
+
+lookup_token_action(Char, Action) :-
+ % The body of this predicate should be turned into a single table lookup
+ % by the compiler.
+ (
+ % This list of characters comes from the code of char.is_whitespace.
+ % Any update here will also require an update there.
+ ( Char = ' '
+ ; Char = '\t'
+ ; Char = '\n'
+ ; Char = '\r'
+ ; Char = '\f'
+ ; Char = '\v'
+ ),
+ Action = action_whitespace
+ ;
+ % This list of characters comes from char.is_alnum_or_underscore and
+ % char.lower_upper.
+ ( Char = 'a' ; Char = 'b' ; Char = 'c' ; Char = 'd'
+ ; Char = 'e' ; Char = 'f' ; Char = 'g' ; Char = 'h'
+ ; Char = 'i' ; Char = 'j' ; Char = 'k' ; Char = 'l'
+ ; Char = 'm' ; Char = 'n' ; Char = 'o' ; Char = 'p'
+ ; Char = 'q' ; Char = 'r' ; Char = 's' ; Char = 't'
+ ; Char = 'u' ; Char = 'v' ; Char = 'w' ; Char = 'x'
+ ; Char = 'y' ; Char = 'z'
+ ),
+ Action = action_alpha_lower
+ ;
+ % This list of characters comes from char.is_alnum_or_underscore and
+ % char.lower_upper.
+ ( Char = '_'
+ ; Char = 'A' ; Char = 'B' ; Char = 'C' ; Char = 'D'
+ ; Char = 'E' ; Char = 'F' ; Char = 'G' ; Char = 'H'
+ ; Char = 'I' ; Char = 'J' ; Char = 'K' ; Char = 'L'
+ ; Char = 'M' ; Char = 'N' ; Char = 'O' ; Char = 'P'
+ ; Char = 'Q' ; Char = 'R' ; Char = 'S' ; Char = 'T'
+ ; Char = 'U' ; Char = 'V' ; Char = 'W' ; Char = 'X'
+ ; Char = 'Y' ; Char = 'Z'
+ ),
+ Action = action_alpha_upper_uscore
+ ;
+ Char = '0',
+ Action = action_zero
+ ;
+ % This list of characters comes from char.is_alnum_or_underscore and
+ % char.is_digit.
+ ( Char = '1' ; Char = '2' ; Char = '3' ; Char = '4'
+ ; Char = '5' ; Char = '6' ; Char = '7' ; Char = '8'
+ ; Char = '9'
+ ),
+ Action = action_nonzero_digit
+ ;
+ % These are the characters for which special_token succeeds.
+ ( Char = ('(')
+ ; Char = (')')
+ ; Char = ('[')
+ ; Char = (']')
+ ; Char = ('{')
+ ; Char = ('}')
+ ; Char = ('|')
+ ; Char = (',')
+ ; Char = (';')
+ ),
+ Action = action_special_token
+ ;
+ Char = ('.'),
+ Action = action_dot
+ ;
+ Char = ('%'),
+ Action = action_percent
+ ;
+ ( Char = '"'
+ ; Char = ''''
+ ),
+ Action = action_quote
+ ;
+ Char = ('/'),
+ Action = action_slash
+ ;
+ Char = ('#'),
+ Action = action_hash
+ ;
+ Char = ('`'),
+ Action = action_backquote
+ ;
+ Char = ('$'),
+ Action = action_dollar
+ ;
+ % These are the characters for which graphic_token_char succeeds.
+ % The ones that are commented out have their own actions.
+ ( Char = ('!')
+ % ; Char = ('#') handled as action_hash
+ % ; Char = ('$') handled as action_dollar
+ ; Char = ('&')
+ ; Char = ('*')
+ ; Char = ('+')
+ ; Char = ('-')
+ % ; Char = ('.') handled as action_dot
+ % ; Char = ('/') handled as action_slash
+ ; Char = (':')
+ ; Char = ('<')
+ ; Char = ('=')
+ ; Char = ('>')
+ ; Char = ('?')
+ ; Char = ('@')
+ ; Char = ('^')
+ ; Char = ('~')
+ ; Char = ('\\')
+ ),
+ Action = action_graphic_token
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % Some descendant predicates of `execute_get_token_action' have the job of
+ % consuming input that does not correspond to a token, e.g. skip_to_eol
+ % skips to the end of line and does not produce a token unless it
+ % encounters the end-of-file or an I/O error.
+ %
+ % If a descendant predicate does not produce a token, then it must return
+ % an indication back to `execute_get_token_action' that it did not, then
+ % `execute_get_token_action' will call itself recursively to get the next
+ % token.
+ %
+ % An alternative would be for the descendant predicate which has not
+ % produced a token to call `execute_get_token_action' (indirectly) to get
+ % the next token. However, `execute_get_token_action' calling itself is
+ % preferable as the direct recursion can be compiled to a loop by backends
+ % that cannot otherwise eliminate tail calls.
+ %
+ % We would like to define a type to represent token values being produced
+ % or not:
+ %
+ % :- type maybe_token
+ % ---> yes(token, token_context)
+ % ; no.
+ %
+ % but the heap allocation required to return "yes(Token, Context)" would be
+ % a significant overhead. Instead, each predicate that might not produce a
+ % token returns two values, of type `token' and `maybe_have_valid_token'
+ % (below).
+ %
+ % If the predicate does produce a token then it returns the token and the
+ % context. This corresponds to the "yes(Token, Context)" case.
+ %
+ % If the predicate does not produce a token then it returns a dummy token
+ % value (that must be ignored) and an invalid context, i.e. one for which
+ % have_token_with_context fails. This corresponds to the "no" case.
+ %
+:- type maybe_have_valid_token
+ ---> maybe_have_valid_token(token_context).
+
+:- pred have_token(io.input_stream::in, maybe_have_valid_token::out,
+ io::di, io::uo) is det.
+
+have_token(Stream, maybe_have_valid_token(Context), !IO) :-
+ get_context(Stream, Context, !IO).
+
+:- pred string_have_token(posn::in, maybe_have_valid_token::out,
+ posn::in, posn::out) is det.
+
+string_have_token(Posn0, maybe_have_valid_token(Context), !Posn) :-
+ string_get_context(Posn0, Context, !Posn).
+
+:- pred do_not_have_token(token::out, maybe_have_valid_token::out) is det.
+
+do_not_have_token(Token, HaveToken) :-
+ Token = eof, % dummy
+ HaveToken = maybe_have_valid_token(-1). % invalid context
+
+:- pred have_token_with_context(maybe_have_valid_token::in, token_context::out)
+ is semidet.
+
+have_token_with_context(maybe_have_valid_token(Context), Context) :-
+ Context \= -1.
+
+%---------------------------------------------------------------------------%
+
+ % Handle the character we just read the way lookup_token_action decided
+ % it should be treated. Note that inlining this predicate does not
+ % significantly affect performance.
+ %
+:- pred execute_get_token_action(io.input_stream::in, char::in,
+ get_token_action::in, scanned_past_whitespace::in, token::out,
+ token_context::out, io::di, io::uo) is det.
+% :- pragma inline(execute_get_token_action/8).
+
+execute_get_token_action(Stream, Char, Action, ScannedPastWhiteSpace,
+ Token, Context, !IO) :-
+ (
+ Action = action_whitespace,
+ get_token_2(Stream, scanned_past_whitespace, Token, Context, !IO)
+ ;
+ Action = action_alpha_upper_uscore,
+ get_context(Stream, Context, !IO),
+ get_variable(Stream, [Char], Token, !IO)
+ ;
+ Action = action_alpha_lower,
+ get_context(Stream, Context, !IO),
+ get_name(Stream, [Char], Token, !IO)
+ ;
+ Action = action_zero,
+ get_context(Stream, Context, !IO),
+ get_zero(Stream, Token, !IO)
+ ;
+ Action = action_nonzero_digit,
+ get_context(Stream, Context, !IO),
+ get_number(Stream, last_digit_is_not_underscore, [Char], Token, !IO)
+ ;
+ Action = action_special_token,
+ get_context(Stream, Context, !IO),
+ handle_special_token(Char, ScannedPastWhiteSpace, Token)
+ ;
+ Action = action_dot,
+ get_context(Stream, Context, !IO),
+ get_dot(Stream, Token, !IO)
+ ;
+ Action = action_quote,
+ get_context(Stream, Context, !IO),
+ start_quoted_name(Stream, Char, [], Token, !IO)
+ ;
+ (
+ Action = action_percent,
+ skip_to_eol(Stream, Token0, HaveToken0, !IO)
+ ;
+ Action = action_slash,
+ get_slash(Stream, Token0, HaveToken0, !IO)
+ ),
+ ( if have_token_with_context(HaveToken0, Context0) then
+ Token = Token0,
+ Context = Context0
+ else
+ get_token_2(Stream, scanned_past_whitespace, Token, Context, !IO)
+ )
+ ;
+ Action = action_hash,
+ get_source_line_number(Stream, [], Token0, HaveToken0, !IO),
+ ( if have_token_with_context(HaveToken0, Context0) then
+ Token = Token0,
+ Context = Context0
+ else
+ get_token_2(Stream, not_scanned_past_whitespace, Token, Context,
+ !IO)
+ )
+ ;
+ Action = action_backquote,
+ get_context(Stream, Context, !IO),
+ Token = name("`")
+ ;
+ Action = action_dollar,
+ get_context(Stream, Context, !IO),
+ get_implementation_defined_literal_rest(Stream, Token, !IO)
+ ;
+ Action = action_graphic_token,
+ get_context(Stream, Context, !IO),
+ get_graphic(Stream, [Char], Token, !IO)
+ ).
+
+ % The string version of execute_get_token_action.
+ %
+:- pred execute_string_get_token_action(string::in, int::in, posn::in,
+ char::in, get_token_action::in, scanned_past_whitespace::in, token::out,
+ token_context::out, posn::in, posn::out) is det.
+% :- pragma inline(execute_string_get_token_action/10).
+
+execute_string_get_token_action(String, Len, Posn0, Char, Action,
+ ScannedPastWhiteSpace, Token, Context, !Posn) :-
+ (
+ Action = action_whitespace,
+ string_get_token_2(String, Len, scanned_past_whitespace,
+ Token, Context, !Posn)
+ ;
+ Action = action_alpha_upper_uscore,
+ string_get_variable(String, Len, Posn0, Token, Context, !Posn)
+ ;
+ Action = action_alpha_lower,
+ string_get_name(String, Len, Posn0, Token, Context, !Posn)
+ ;
+ Action = action_zero,
+ string_get_zero(String, Len, Posn0, Token, Context, !Posn)
+ ;
+ Action = action_nonzero_digit,
+ LastDigit = last_digit_is_not_underscore,
+ string_get_number(String, LastDigit, Len, Posn0, Token, Context,
+ !Posn)
+ ;
+ Action = action_special_token,
+ string_get_context(Posn0, Context, !Posn),
+ handle_special_token(Char, ScannedPastWhiteSpace, Token)
+ ;
+ Action = action_dot,
+ string_get_dot(String, Len, Posn0, Token, Context, !Posn)
+ ;
+ Action = action_quote,
+ string_start_quoted_name(String, Len, Char, [], Posn0, Token,
+ Context, !Posn)
+ ;
+ (
+ Action = action_percent,
+ string_skip_to_eol(String, Len, Token0, HaveToken0, !Posn)
+ ;
+ Action = action_slash,
+ string_get_slash(String, Len, Posn0, Token0, HaveToken0, !Posn)
+ ),
+ ( if have_token_with_context(HaveToken0, Context0) then
+ Token = Token0,
+ Context = Context0
+ else
+ string_get_token_2(String, Len, scanned_past_whitespace,
+ Token, Context, !Posn)
+ )
+ ;
+ Action = action_hash,
+ string_get_source_line_number(String, Len, !.Posn, Token0, HaveToken0,
+ !Posn),
+ ( if have_token_with_context(HaveToken0, Context0) then
+ Token = Token0,
+ Context = Context0
+ else
+ string_get_token_2(String, Len, not_scanned_past_whitespace,
+ Token, Context, !Posn)
+ )
+ ;
+ Action = action_backquote,
+ string_get_context(Posn0, Context, !Posn),
+ Token = name("`")
+ ;
+ Action = action_dollar,
+ string_get_implementation_defined_literal_rest(String, Len, Posn0,
+ Token, Context, !Posn)
+ ;
+ Action = action_graphic_token,
+ string_get_graphic(String, Len, Posn0, Token, Context, !Posn)
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % Decide what to do for a token which consists of a special character.
+ % The reason for inlining this predicate is that each caller has a
+ % specific value for ScannedPastWhiteSpace, and thus after inlining,
+ % the compiler should be able to eliminate the switch on
+ % ScannedPastWhiteSpace.
+ %
+:- pred handle_special_token(char::in, scanned_past_whitespace::in, token::out)
+ is det.
+:- pragma inline(handle_special_token/3).
+
+handle_special_token(Char, ScannedPastWhiteSpace, Token) :-
+ ( if special_token(Char, SpecialToken) then
+ (
+ ScannedPastWhiteSpace = not_scanned_past_whitespace,
+ ( if SpecialToken = open then
+ Token = open_ct
+ else
+ Token = SpecialToken
+ )
+ ;
+ ScannedPastWhiteSpace = scanned_past_whitespace,
+ Token = SpecialToken
+ )
+ else
+ error("old_lexer.m: handle_special_token: unknown special token")
+ ).
+
+:- pred special_token(char::in, token::out) is semidet.
+
+% The list of characters here is duplicated in lookup_token_action above.
+special_token('(', open). % May get converted to open_ct above.
+special_token(')', close).
+special_token('[', open_list).
+special_token(']', close_list).
+special_token('{', open_curly).
+special_token('}', close_curly).
+special_token('|', ht_sep).
+special_token(',', comma).
+special_token(';', name(";")).
+
+% The list of characters here is duplicated in lookup_token_action above.
+graphic_token_char('!').
+graphic_token_char('#').
+graphic_token_char('$').
+graphic_token_char('&').
+graphic_token_char('*').
+graphic_token_char('+').
+graphic_token_char('-').
+graphic_token_char('.').
+graphic_token_char('/').
+graphic_token_char(':').
+graphic_token_char('<').
+graphic_token_char('=').
+graphic_token_char('>').
+graphic_token_char('?').
+graphic_token_char('@').
+graphic_token_char('^').
+graphic_token_char('~').
+graphic_token_char('\\').
+
+%---------------------------------------------------------------------------%
+
+:- pred get_dot(io.input_stream::in, token::out, io::di, io::uo) is det.
+
+get_dot(Stream, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = end
+ ;
+ Result = ok,
+ ( if whitespace_after_dot(Char) then
+ io.putback_char(Stream, Char, !IO),
+ Token = end
+ else if graphic_token_char(Char) then
+ get_graphic(Stream, [Char, '.'], Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = name(".")
+ )
+ ).
+
+:- pred string_get_dot(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_dot(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if whitespace_after_dot(Char) then
+ string_ungetchar(String, !Posn),
+ string_get_context(Posn0, Context, !Posn),
+ Token = end
+ else if graphic_token_char(Char) then
+ string_get_graphic(String, Len, Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ string_get_context(Posn0, Context, !Posn),
+ Token = name(".")
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = end
+ ).
+
+:- pred whitespace_after_dot(char::in) is semidet.
+
+whitespace_after_dot(Char) :-
+ ( char.is_whitespace(Char)
+ ; Char = '%'
+ ).
+
+%---------------------------------------------------------------------------%
+%
+% Comments.
+%
+
+:- pred skip_to_eol(io.input_stream::in, token::out,
+ maybe_have_valid_token::out, io::di, io::uo) is det.
+
+skip_to_eol(Stream, Token, HaveToken, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ have_token(Stream, HaveToken, !IO),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ have_token(Stream, HaveToken, !IO),
+ Token = eof
+ ;
+ Result = ok,
+ ( if Char = '\n' then
+ do_not_have_token(Token, HaveToken)
+ else
+ skip_to_eol(Stream, Token, HaveToken, !IO)
+ )
+ ).
+
+:- pred string_skip_to_eol(string::in, int::in, token::out,
+ maybe_have_valid_token::out, posn::in, posn::out) is det.
+
+string_skip_to_eol(String, Len, Token, HaveToken, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if Char = '\n' then
+ do_not_have_token(Token, HaveToken)
+ else
+ string_skip_to_eol(String, Len, Token, HaveToken, !Posn)
+ )
+ else
+ string_have_token(!.Posn, HaveToken, !Posn),
+ Token = eof
+ ).
+
+:- pred get_slash(io.input_stream::in, token::out, maybe_have_valid_token::out,
+ io::di, io::uo) is det.
+
+get_slash(Stream, Token, HaveToken, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ have_token(Stream, HaveToken, !IO),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ have_token(Stream, HaveToken, !IO),
+ Token = name("/")
+ ;
+ Result = ok,
+ ( if Char = ('*') then
+ get_comment(Stream, Token, HaveToken, !IO)
+ else if graphic_token_char(Char) then
+ get_graphic(Stream, [Char, '/'], Token, !IO),
+ have_token(Stream, HaveToken, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ have_token(Stream, HaveToken, !IO),
+ Token = name("/")
+ )
+ ).
+
+:- pred string_get_slash(string::in, int::in, posn::in, token::out,
+ maybe_have_valid_token::out, posn::in, posn::out) is det.
+
+string_get_slash(String, Len, Posn0, Token, HaveToken, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if Char = ('*') then
+ string_get_comment(String, Len, Posn0, Token, HaveToken, !Posn)
+ else if graphic_token_char(Char) then
+ string_get_graphic(String, Len, Posn0, Token, Context, !Posn),
+ HaveToken = maybe_have_valid_token(Context)
+ else
+ string_ungetchar(String, !Posn),
+ string_have_token(Posn0, HaveToken, !Posn),
+ Token = name("/")
+ )
+ else
+ string_have_token(Posn0, HaveToken, !Posn),
+ Token = name("/")
+ ).
+
+:- pred get_comment(io.input_stream::in, token::out,
+ maybe_have_valid_token::out, io::di, io::uo) is det.
+
+get_comment(Stream, Token, HaveToken, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ have_token(Stream, HaveToken, !IO),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ have_token(Stream, HaveToken, !IO),
+ Token = error("unterminated '/*' comment")
+ ;
+ Result = ok,
+ ( if Char = ('*') then
+ get_comment_2(Stream, Token, HaveToken, !IO)
+ else
+ get_comment(Stream, Token, HaveToken, !IO)
+ )
+ ).
+
+:- pred string_get_comment(string::in, int::in, posn::in, token::out,
+ maybe_have_valid_token::out, posn::in, posn::out) is det.
+
+string_get_comment(String, Len, Posn0, Token, HaveToken, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if Char = ('*') then
+ string_get_comment_2(String, Len, Posn0, Token, HaveToken, !Posn)
+ else
+ string_get_comment(String, Len, Posn0, Token, HaveToken, !Posn)
+ )
+ else
+ string_have_token(Posn0, HaveToken, !Posn),
+ Token = error("unterminated '/*' comment")
+ ).
+
+:- pred get_comment_2(io.input_stream::in, token::out,
+ maybe_have_valid_token::out, io::di, io::uo) is det.
+
+get_comment_2(Stream, Token, HaveToken, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ have_token(Stream, HaveToken, !IO),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ have_token(Stream, HaveToken, !IO),
+ Token = error("unterminated '/*' comment")
+ ;
+ Result = ok,
+ ( if Char = ('/') then
+ % end of /* ... */ comment, so get next token
+ do_not_have_token(Token, HaveToken)
+ else if Char = ('*') then
+ get_comment_2(Stream, Token, HaveToken, !IO)
+ else
+ get_comment(Stream, Token, HaveToken, !IO)
+ )
+ ).
+
+:- pred string_get_comment_2(string::in, int::in, posn::in, token::out,
+ maybe_have_valid_token::out, posn::in, posn::out) is det.
+
+string_get_comment_2(String, Len, Posn0, Token, HaveToken, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if Char = ('/') then
+ % end of /* ... */ comment, so get next token
+ do_not_have_token(Token, HaveToken)
+ else if Char = ('*') then
+ string_get_comment_2(String, Len, Posn0, Token, HaveToken, !Posn)
+ else
+ string_get_comment(String, Len, Posn0, Token, HaveToken, !Posn)
+ )
+ else
+ string_have_token(Posn0, HaveToken, !Posn),
+ Token = error("unterminated '/*' comment")
+ ).
+
+%---------------------------------------------------------------------------%
+%
+% Quoted names and quoted strings.
+%
+
+:- pred start_quoted_name(io.input_stream::in, char::in, list(char)::in,
+ token::out, io::di, io::uo) is det.
+
+start_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO) :-
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token0, !IO),
+ ( if Token0 = error(_) then
+ % Skip to the end of the string or name.
+ start_quoted_name(Stream, QuoteChar, !.RevChars, _, !IO),
+ Token = Token0
+ else if Token0 = eof then
+ Token = error("unterminated quote")
+ else
+ Token = Token0
+ ).
+
+:- pred string_start_quoted_name(string::in, int::in, char::in,
+ list(char)::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_start_quoted_name(String, Len, QuoteChar, !.RevChars, Posn0,
+ Token, Context, !Posn) :-
+ string_get_quoted_name(String, Len, QuoteChar, !.RevChars, Posn0,
+ Token0, Context, !Posn),
+ ( if Token0 = error(_) then
+ % Skip to the end of the string or name.
+ string_start_quoted_name(String, Len, QuoteChar, !.RevChars,
+ Posn0, _, _, !Posn),
+ Token = Token0
+ else if Token0 = eof then
+ Token = error("unterminated quote")
+ else
+ Token = Token0
+ ).
+
+:- pred get_quoted_name(io.input_stream::in, char::in, list(char)::in,
+ token::out, io::di, io::uo) is det.
+
+get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = eof
+ ;
+ Result = ok,
+ ( if Char = QuoteChar then
+ get_quoted_name_quote(Stream, QuoteChar, !.RevChars, Token, !IO)
+ else if Char = ('\\') then
+ get_quoted_name_escape(Stream, QuoteChar, !.RevChars, Token, !IO)
+ else
+ !:RevChars = [Char | !.RevChars],
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO)
+ )
+ ).
+
+:- pred string_get_quoted_name(string::in, int::in, char::in,
+ list(char)::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_quoted_name(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if Char = QuoteChar then
+ string_get_quoted_name_quote(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn)
+ else if Char = ('\\') then
+ string_get_quoted_name_escape(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn)
+ else
+ !:RevChars = [Char | !.RevChars],
+ string_get_quoted_name(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn)
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = eof
+ ).
+
+:- pred get_quoted_name_quote(io.input_stream::in, char::in, list(char)::in,
+ token::out, io::di, io::uo) is det.
+
+get_quoted_name_quote(Stream, QuoteChar, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ finish_quoted_name(QuoteChar, !.RevChars, Token)
+ ;
+ Result = ok,
+ ( if Char = QuoteChar then
+ !:RevChars = [Char | !.RevChars],
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ finish_quoted_name(QuoteChar, !.RevChars, Token)
+ )
+ ).
+
+:- pred string_get_quoted_name_quote(string::in, int::in, char::in,
+ list(char)::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_quoted_name_quote(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if Char = QuoteChar then
+ !:RevChars = [Char | !.RevChars],
+ string_get_quoted_name(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ string_get_context(Posn0, Context, !Posn),
+ finish_quoted_name(QuoteChar, !.RevChars, Token)
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ finish_quoted_name(QuoteChar, !.RevChars, Token)
+ ).
+
+:- pred finish_quoted_name(char::in, list(char)::in, token::out) is det.
+
+finish_quoted_name(QuoteChar, RevChars, Token) :-
+ ( if rev_char_list_to_string(RevChars, String) then
+ ( if QuoteChar = '''' then
+ Token = name(String)
+ else if QuoteChar = '"' then
+ Token = string(String)
+ else
+ error("old_lexer.m: unknown quote character")
+ )
+ else
+ Token = error("invalid character in quoted name")
+ ).
+
+:- pred get_quoted_name_escape(io.input_stream::in, char::in, list(char)::in,
+ token::out, io::di, io::uo) is det.
+
+get_quoted_name_escape(Stream, QuoteChar, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = eof
+ ;
+ Result = ok,
+ ( if Char = '\n' then
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO)
+ else if Char = '\r' then
+ % Files created on Windows may have an extra return character.
+ get_quoted_name_escape(Stream, QuoteChar, !.RevChars, Token, !IO)
+ else if escape_char(Char, EscapedChar) then
+ !:RevChars = [EscapedChar | !.RevChars],
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO)
+ else if Char = 'x' then
+ get_hex_escape(Stream, QuoteChar, !.RevChars, [], Token, !IO)
+ else if Char = 'u' then
+ get_unicode_escape(Stream, 4, QuoteChar, !.RevChars, [],
+ Token, !IO)
+ else if Char = 'U' then
+ get_unicode_escape(Stream, 8, QuoteChar, !.RevChars, [],
+ Token, !IO)
+ else if char.is_octal_digit(Char) then
+ get_octal_escape(Stream, QuoteChar, !.RevChars, [Char], Token, !IO)
+ else
+ Token = error("invalid escape character")
+ )
+ ).
+
+:- pred string_get_quoted_name_escape(string::in, int::in, char::in,
+ list(char)::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_quoted_name_escape(String, Len, QuoteChar, !.RevChars, Posn0,
+ Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if Char = '\n' then
+ string_get_quoted_name(String, Len, QuoteChar,
+ !.RevChars, Posn0, Token, Context, !Posn)
+ else if Char = '\r' then
+ % Files created on Windows may have an extra return character.
+ string_get_quoted_name_escape(String, Len, QuoteChar,
+ !.RevChars, Posn0, Token, Context, !Posn)
+ else if escape_char(Char, EscapedChar) then
+ !:RevChars = [EscapedChar | !.RevChars],
+ string_get_quoted_name(String, Len, QuoteChar,
+ !.RevChars, Posn0, Token, Context, !Posn)
+ else if Char = 'x' then
+ string_get_hex_escape(String, Len, QuoteChar,
+ !.RevChars, [], Posn0, Token, Context, !Posn)
+ else if Char = 'u' then
+ string_get_unicode_escape(4, String, Len, QuoteChar,
+ !.RevChars, [], Posn0, Token, Context, !Posn)
+ else if Char = 'U' then
+ string_get_unicode_escape(8, String, Len, QuoteChar,
+ !.RevChars, [], Posn0, Token, Context, !Posn)
+ else if char.is_octal_digit(Char) then
+ string_get_octal_escape(String, Len, QuoteChar,
+ !.RevChars, [Char], Posn0, Token, Context, !Posn)
+ else
+ string_get_context(!.Posn, Context, !Posn),
+ Token = error("invalid escape character")
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = eof
+ ).
+
+:- pred escape_char(char::in, char::out) is semidet.
+
+escape_char('a', '\a').
+escape_char('b', '\b').
+escape_char('r', '\r').
+escape_char('f', '\f').
+escape_char('t', '\t').
+escape_char('n', '\n').
+escape_char('v', '\v').
+escape_char('\\', '\\').
+escape_char('''', '''').
+escape_char('"', '"').
+escape_char('`', '`').
+
+:- pred get_unicode_escape(io.input_stream::in, int::in, char::in,
+ list(char)::in, list(char)::in, token::out, io::di, io::uo) is det.
+
+get_unicode_escape(Stream, NumHexChars, QuoteChar, !.RevChars, !.RevHexChars,
+ Token, !IO) :-
+ ( if NumHexChars = list.length(!.RevHexChars) then
+ ( if
+ rev_char_list_to_string(!.RevHexChars, HexString),
+ string.base_string_to_int(16, HexString, UnicodeCharCode),
+ allowed_unicode_char_code(UnicodeCharCode),
+ char.from_int(UnicodeCharCode, UnicodeChar)
+ then
+ ( if UnicodeCharCode = 0 then
+ Token = null_character_error
+ else
+ !:RevChars = [UnicodeChar | !.RevChars],
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO)
+ )
+ else
+ Token = error("invalid Unicode character code")
+ )
+ else
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = eof
+ ;
+ Result = ok,
+ ( if char.is_hex_digit(Char) then
+ !:RevHexChars = [Char | !.RevHexChars],
+ get_unicode_escape(Stream, NumHexChars, QuoteChar,
+ !.RevChars, !.RevHexChars, Token, !IO)
+ else
+ Token = error("invalid hex character in Unicode escape")
+ )
+ )
+ ).
+
+:- pred string_get_unicode_escape(int::in, string::in, int::in, char::in,
+ list(char)::in, list(char)::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_unicode_escape(NumHexChars, String, Len, QuoteChar,
+ !.RevChars, !.RevHexChars, Posn0, Token, Context, !Posn) :-
+ ( if NumHexChars = list.length(!.RevHexChars) then
+ ( if
+ rev_char_list_to_string(!.RevHexChars, HexString),
+ string.base_string_to_int(16, HexString, UnicodeCharCode),
+ allowed_unicode_char_code(UnicodeCharCode),
+ char.from_int(UnicodeCharCode, UnicodeChar)
+ then
+ ( if UnicodeCharCode = 0 then
+ string_get_context(Posn0, Context, !Posn),
+ Token = null_character_error
+ else
+ !:RevChars = [UnicodeChar | !.RevChars],
+ string_get_quoted_name(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn)
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = error("invalid Unicode character code")
+ )
+ else
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_hex_digit(Char) then
+ !:RevHexChars = [Char | !.RevHexChars],
+ string_get_unicode_escape(NumHexChars, String, Len, QuoteChar,
+ !.RevChars, !.RevHexChars, Posn0, Token, Context, !Posn)
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = error("invalid hex character in Unicode escape")
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = eof
+ )
+ ).
+
+ % Succeeds if the give code point is a legal Unicode code point
+ % (regardless of whether it is reserved for private use or not).
+ %
+:- pred allowed_unicode_char_code(int::in) is semidet.
+
+allowed_unicode_char_code(Code) :-
+ Code >= 0,
+ Code =< 0x10FFFF,
+ % The following range is reserved for surrogates.
+ not (
+ Code >= 0xD800, Code =< 0xDFFF
+ ).
+
+:- pred get_hex_escape(io.input_stream::in, char::in, list(char)::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_hex_escape(Stream, QuoteChar, !.RevChars, !.RevHexChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = eof
+ ;
+ Result = ok,
+ ( if char.is_hex_digit(Char) then
+ !:RevHexChars = [Char | !.RevHexChars],
+ get_hex_escape(Stream, QuoteChar, !.RevChars, !.RevHexChars,
+ Token, !IO)
+ else if Char = ('\\') then
+ finish_hex_escape(Stream, QuoteChar, !.RevChars, !.RevHexChars,
+ Token, !IO)
+ else
+ Token = error("unterminated hex escape")
+ )
+ ).
+
+:- pred string_get_hex_escape(string::in, int::in, char::in,
+ list(char)::in, list(char)::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_hex_escape(String, Len, QuoteChar, !.RevChars, !.RevHexChars,
+ Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_hex_digit(Char) then
+ !:RevHexChars = [Char | !.RevHexChars],
+ string_get_hex_escape(String, Len, QuoteChar,
+ !.RevChars, !.RevHexChars, Posn0, Token, Context, !Posn)
+ else if Char = ('\\') then
+ string_finish_hex_escape(String, Len, QuoteChar, !.RevChars,
+ !.RevHexChars, Posn0, Token, Context, !Posn)
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = error("unterminated hex escape")
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = eof
+ ).
+
+:- pred finish_hex_escape(io.input_stream::in, char::in, list(char)::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+finish_hex_escape(Stream, QuoteChar, !.RevChars, !.RevHexChars, Token, !IO) :-
+ (
+ !.RevHexChars = [],
+ Token = error("empty hex escape")
+ ;
+ !.RevHexChars = [_ | _],
+ ( if
+ rev_char_list_to_string(!.RevHexChars, HexString),
+ string.base_string_to_int(16, HexString, Int),
+ char.to_int(Char, Int)
+ then
+ ( if Int = 0 then
+ Token = null_character_error
+ else
+ !:RevChars = [Char | !.RevChars],
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO)
+ )
+ else
+ Token = error("invalid hex escape")
+ )
+ ).
+
+:- pred string_finish_hex_escape(string::in, int::in, char::in,
+ list(char)::in, list(char)::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_finish_hex_escape(String, Len, QuoteChar, !.RevChars, !.RevHexChars,
+ Posn0, Token, Context, !Posn) :-
+ (
+ !.RevHexChars = [],
+ string_get_context(Posn0, Context, !Posn),
+ Token = error("empty hex escape")
+ ;
+ !.RevHexChars = [_ | _],
+ ( if
+ rev_char_list_to_string(!.RevHexChars, HexString),
+ string.base_string_to_int(16, HexString, Int),
+ char.to_int(Char, Int)
+ then
+ ( if Int = 0 then
+ Token = null_character_error,
+ string_get_context(Posn0, Context, !Posn)
+ else
+ !:RevChars = [Char | !.RevChars],
+ string_get_quoted_name(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn)
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = error("invalid hex escape")
+ )
+ ).
+
+:- pred get_octal_escape(io.input_stream::in, char::in, list(char)::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_octal_escape(Stream, QuoteChar, !.RevChars, !.RevOctalChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = eof
+ ;
+ Result = ok,
+ ( if char.is_octal_digit(Char) then
+ !:RevOctalChars = [Char | !.RevOctalChars],
+ get_octal_escape(Stream, QuoteChar, !.RevChars, !.RevOctalChars,
+ Token, !IO)
+ else if Char = ('\\') then
+ finish_octal_escape(Stream, QuoteChar, !.RevChars, !.RevOctalChars,
+ Token, !IO)
+ else
+ Token = error("unterminated octal escape")
+ )
+ ).
+
+:- pred string_get_octal_escape(string::in, int::in, char::in,
+ list(char)::in, list(char)::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_octal_escape(String, Len, QuoteChar, !.RevChars, !.RevOctalChars,
+ Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_octal_digit(Char) then
+ !:RevOctalChars = [Char | !.RevOctalChars],
+ string_get_octal_escape(String, Len, QuoteChar,
+ !.RevChars, !.RevOctalChars, Posn0, Token, Context, !Posn)
+ else if Char = ('\\') then
+ string_finish_octal_escape(String, Len, QuoteChar,
+ !.RevChars, !.RevOctalChars, Posn0, Token, Context, !Posn)
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = error("unterminated octal escape")
+ )
+ else
+ Token = eof,
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred finish_octal_escape(io.input_stream::in, char::in, list(char)::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+finish_octal_escape(Stream, QuoteChar, !.RevChars, !.RevOctalChars,
+ Token, !IO) :-
+ (
+ !.RevOctalChars = [],
+ Token = error("empty octal escape")
+ ;
+ !.RevOctalChars = [_ | _],
+ ( if
+ rev_char_list_to_string(!.RevOctalChars, OctalString),
+ string.base_string_to_int(8, OctalString, Int),
+ char.to_int(Char, Int)
+ then
+ ( if Int = 0 then
+ Token = null_character_error
+ else
+ !:RevChars = [Char | !.RevChars],
+ get_quoted_name(Stream, QuoteChar, !.RevChars, Token, !IO)
+ )
+ else
+ Token = error("invalid octal escape")
+ )
+ ).
+
+:- pred string_finish_octal_escape(string::in, int::in, char::in,
+ list(char)::in, list(char)::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_finish_octal_escape(String, Len, QuoteChar, !.RevChars, !.RevOctalChars,
+ Posn0, Token, Context, !Posn) :-
+ (
+ !.RevOctalChars = [],
+ Token = error("empty octal escape"),
+ string_get_context(Posn0, Context, !Posn)
+ ;
+ !.RevOctalChars = [_ | _],
+ ( if
+ rev_char_list_to_string(!.RevOctalChars, OctalString),
+ string.base_string_to_int(8, OctalString, Int),
+ char.to_int(Char, Int)
+ then
+ ( if Int = 0 then
+ Token = null_character_error,
+ string_get_context(Posn0, Context, !Posn)
+ else
+ !:RevChars = [Char | !.RevChars],
+ string_get_quoted_name(String, Len, QuoteChar, !.RevChars,
+ Posn0, Token, Context, !Posn)
+ )
+ else
+ Token = error("invalid octal escape"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+%
+% Names and variables.
+%
+
+:- pred get_name(io.input_stream::in, list(char)::in, token::out,
+ io::di, io::uo) is det.
+
+get_name(Stream, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ ( if rev_char_list_to_string(!.RevChars, Name) then
+ Token = name(Name)
+ else
+ Token = error("invalid character in name")
+ )
+ ;
+ Result = ok,
+ ( if char.is_alnum_or_underscore(Char) then
+ !:RevChars = [Char | !.RevChars],
+ get_name(Stream, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ ( if rev_char_list_to_string(!.RevChars, Name) then
+ Token = name(Name)
+ else
+ Token = error("invalid character in name")
+ )
+ )
+ ).
+
+:- pred string_get_name(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_name(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_alnum_or_underscore(Char) then
+ string_get_name(String, Len, Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ grab_string(String, Posn0, Name, !Posn),
+ Token = name(Name),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ grab_string(String, Posn0, Name, !Posn),
+ Token = name(Name),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred get_implementation_defined_literal_rest(io.input_stream::in,
+ token::out, io::di, io::uo) is det.
+
+get_implementation_defined_literal_rest(Stream, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = name("$")
+ ;
+ Result = ok,
+ ( if char.is_lower(Char) then
+ get_name(Stream, [Char], Token0, !IO),
+ ( if Token0 = name(S) then
+ Token = implementation_defined(S)
+ else
+ Token = Token0
+ )
+ else if graphic_token_char(Char) then
+ get_graphic(Stream, [Char, '$'], Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = name("$")
+ )
+ ).
+
+:- pred string_get_implementation_defined_literal_rest(string::in, int::in,
+ posn::in, token::out, string_token_context::out, posn::in, posn::out)
+ is det.
+
+string_get_implementation_defined_literal_rest(String, Len, Posn0,
+ Token, Context, !Posn) :-
+ Posn1 = !.Posn,
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_lower(Char) then
+ string_get_name(String, Len, Posn1, Token0, Context, !Posn),
+ ( if Token0 = name(S) then
+ Token = implementation_defined(S)
+ else
+ Token = Token0
+ )
+ else if graphic_token_char(Char) then
+ string_get_graphic(String, Len, Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ Token = name("$"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ Token = name("$"),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+ % A line number directive token is `#' followed by an integer
+ % (specifying the line number) followed by a newline.
+ % Such a token sets the source line number for the next line, but it is
+ % otherwise ignored. This means that line number directives may appear
+ % anywhere that a token may appear, including in the middle of terms.
+ % (The source file name can be set with a `:- pragma source_file'
+ % declaration.)
+ %
+:- pred get_source_line_number(io.input_stream::in, list(char)::in, token::out,
+ maybe_have_valid_token::out, io::di, io::uo) is det.
+
+get_source_line_number(Stream, !.RevChars, Token, HaveToken, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ have_token(Stream, HaveToken, !IO),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ have_token(Stream, HaveToken, !IO),
+ Token = error("unexpected end-of-file in `#' line number directive")
+ ;
+ Result = ok,
+ ( if char.is_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ get_source_line_number(Stream, !.RevChars, Token, HaveToken, !IO)
+ else if Char = '\n' then
+ ( if rev_char_list_to_string(!.RevChars, String) then
+ ( if
+ string.base_string_to_int(10, String, Int),
+ Int > 0
+ then
+ io.set_line_number(Stream, Int, !IO),
+ do_not_have_token(Token, HaveToken)
+ else
+ have_token(Stream, HaveToken, !IO),
+ string.append_list(["invalid line number `", String,
+ "' in `#' line number directive"], Message),
+ Token = error(Message)
+ )
+ else
+ have_token(Stream, HaveToken, !IO),
+ Token = error("invalid character in `#' line number directive")
+ )
+ else
+ have_token(Stream, HaveToken, !IO),
+ ( if char.to_int(Char, 0) then
+ String = "NUL"
+ else
+ string.from_char_list([Char], String)
+ ),
+ string.append_list(["invalid character `", String,
+ "' in `#' line number directive"], Message),
+ Token = error(Message)
+ )
+ ).
+
+:- pred string_get_source_line_number(string::in, int::in, posn::in,
+ token::out, maybe_have_valid_token::out, posn::in, posn::out) is det.
+
+string_get_source_line_number(String, Len, Posn1, Token, HaveToken, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_digit(Char) then
+ string_get_source_line_number(String, Len, Posn1, Token, HaveToken,
+ !Posn)
+ else if Char = '\n' then
+ grab_string(String, Posn1, LineNumString, !Posn),
+ ( if
+ string.base_string_to_int(10, LineNumString, LineNum),
+ LineNum > 0
+ then
+ string_set_line_number(LineNum, !Posn),
+ do_not_have_token(Token, HaveToken)
+ else
+ string_have_token(Posn1, HaveToken, !Posn),
+ string.append_list(["invalid line number `", LineNumString,
+ "' in `#' line number directive"], Message),
+ Token = error(Message)
+ )
+ else
+ string_have_token(Posn1, HaveToken, !Posn),
+ ( if char.to_int(Char, 0) then
+ DirectiveString = "NUL"
+ else
+ string.from_char_list([Char], DirectiveString)
+ ),
+ string.append_list(["invalid character `", DirectiveString,
+ "' in `#' line number directive"], Message),
+ Token = error(Message)
+ )
+ else
+ string_have_token(Posn1, HaveToken, !Posn),
+ Token = error("unexpected end-of-file in `#' line number directive")
+ ).
+
+:- pred get_graphic(io.input_stream::in, list(char)::in, token::out,
+ io::di, io::uo) is det.
+
+get_graphic(Stream, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ ( if rev_char_list_to_string(!.RevChars, Name) then
+ Token = name(Name)
+ else
+ Token = error("invalid character in graphic token")
+ )
+ ;
+ Result = ok,
+ ( if graphic_token_char(Char) then
+ !:RevChars = [Char | !.RevChars],
+ get_graphic(Stream, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ ( if rev_char_list_to_string(!.RevChars, Name) then
+ Token = name(Name)
+ else
+ Token = error("invalid character in graphic token")
+ )
+ )
+ ).
+
+:- pred string_get_graphic(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_graphic(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if graphic_token_char(Char) then
+ string_get_graphic(String, Len, Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ grab_string(String, Posn0, Name, !Posn),
+ Token = name(Name),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ grab_string(String, Posn0, Name, !Posn),
+ string_get_context(Posn0, Context, !Posn),
+ Token = name(Name)
+ ).
+
+:- pred get_variable(io.input_stream::in, list(char)::in, token::out,
+ io::di, io::uo) is det.
+
+get_variable(Stream, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ ( if rev_char_list_to_string(!.RevChars, VariableName) then
+ Token = variable(VariableName)
+ else
+ Token = error("invalid character in variable")
+ )
+ ;
+ Result = ok,
+ ( if char.is_alnum_or_underscore(Char) then
+ !:RevChars = [Char | !.RevChars],
+ get_variable(Stream, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ ( if rev_char_list_to_string(!.RevChars, VariableName) then
+ Token = variable(VariableName)
+ else
+ Token = error("invalid character in variable")
+ )
+ )
+ ).
+
+:- pred string_get_variable(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_variable(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_alnum_or_underscore(Char) then
+ string_get_variable(String, Len, Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ grab_string(String, Posn0, VariableName, !Posn),
+ Token = variable(VariableName),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ grab_string(String, Posn0, VariableName, !Posn),
+ Token = variable(VariableName),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+%---------------------------------------------------------------------------%
+%
+% Integer and float literals.
+%
+
+:- pred get_zero(io.input_stream::in, token::out, io::di, io::uo) is det.
+
+get_zero(Stream, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = integer(0)
+ ;
+ Result = ok,
+ ( if char.is_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ get_number(Stream, LastDigit, [Char], Token, !IO)
+ else if Char = '_' then
+ LastDigit = last_digit_is_underscore,
+ get_number(Stream, LastDigit, [], Token, !IO)
+ else if Char = '''' then
+ get_char_code(Stream, Token, !IO)
+ else if Char = 'b' then
+ get_binary(Stream, Token, !IO)
+ else if Char = 'o' then
+ get_octal(Stream, Token, !IO)
+ else if Char = 'x' then
+ get_hex(Stream, Token, !IO)
+ else if Char = ('.') then
+ LastDigit = last_digit_is_not_underscore,
+ get_int_dot(Stream, LastDigit, ['0'], Token, !IO)
+ else if ( Char = 'e' ; Char = 'E' ) then
+ get_float_exponent(Stream, [Char, '0'], Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = integer(0)
+ )
+ ).
+
+ % This type records whether the last "digit" seen by the
+ % lexer as it process a numeric token was an underscore or not.
+ % This is needed to detect invalid uses of underscores in numeric
+ % literals.
+ % Note that there may be other intervening characters in the
+ % token between the last digit and the current one (e.g. the
+ % decimal point or beginning of an exponent a float literal.)
+ %
+:- type last_digit_is_underscore
+ ---> last_digit_is_underscore
+ ; last_digit_is_not_underscore.
+
+:- pred string_get_zero(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_zero(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ string_get_number(String, LastDigit, Len, Posn0, Token, Context,
+ !Posn)
+ else if Char = '_' then
+ LastDigit = last_digit_is_underscore,
+ string_get_number(String, LastDigit, Len, Posn0, Token, Context,
+ !Posn)
+ else if Char = '''' then
+ string_get_char_code(String, Len, Posn0, Token, Context, !Posn)
+ else if Char = 'b' then
+ string_get_binary(String, Len, Posn0, Token, Context, !Posn)
+ else if Char = 'o' then
+ string_get_octal(String, Len, Posn0, Token, Context, !Posn)
+ else if Char = 'x' then
+ string_get_hex(String, Len, Posn0, Token, Context, !Posn)
+ else if Char = ('.') then
+ LastDigit = last_digit_is_not_underscore,
+ string_get_int_dot(String, LastDigit, Len, Posn0, Token, Context,
+ !Posn)
+ else if ( Char = 'e' ; Char = 'E' ) then
+ string_get_float_exponent(String, Len, Posn0, Token, Context,
+ !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ string_get_context(Posn0, Context, !Posn),
+ Token = integer(0)
+ )
+ else
+ string_get_context(Posn0, Context, !Posn),
+ Token = integer(0)
+ ).
+
+:- pred get_char_code(io.input_stream::in, token::out, io::di, io::uo) is det.
+
+get_char_code(Stream, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = error("unterminated char code literal")
+ ;
+ Result = ok,
+ char.to_int(Char, CharCode),
+ Token = integer(CharCode)
+ ).
+
+:- pred string_get_char_code(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_char_code(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ char.to_int(Char, CharCode),
+ Token = integer(CharCode),
+ string_get_context(Posn0, Context, !Posn)
+ else
+ Token = error("unterminated char code literal"),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred get_binary(io.input_stream::in, token::out, io::di, io::uo) is det.
+
+get_binary(Stream, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = error("unterminated binary literal")
+ ;
+ Result = ok,
+ ( if char.is_binary_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ get_binary_2(Stream, LastDigit, [Char], Token, !IO)
+ else if Char = '_' then
+ get_binary(Stream, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = error("unterminated binary literal")
+ )
+ ).
+
+:- pred string_get_binary(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_binary(String, Len, Posn0, Token, Context, !Posn) :-
+ Posn1 = !.Posn,
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_binary_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ string_get_binary_2(String, LastDigit, Len, Posn1, Token, Context,
+ !Posn)
+ else if Char = '_' then
+ string_get_binary(String, Len, Posn1, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ Token = error("unterminated binary literal"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ Token = error("unterminated binary literal"),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred get_binary_2(io.input_stream::in, last_digit_is_underscore::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_binary_2(Stream, !.LastDigit, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_2, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated binary literal")
+ )
+ ;
+ Result = ok,
+ ( if char.is_binary_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ !:LastDigit = last_digit_is_not_underscore,
+ get_binary_2(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ get_binary_2(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_2, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated binary literal")
+ )
+ )
+ ).
+
+:- pred string_get_binary_2(string::in, last_digit_is_underscore::in,
+ int::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_binary_2(String, !.LastDigit, Len, Posn1, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_binary_digit(Char) then
+ !:LastDigit = last_digit_is_not_underscore,
+ string_get_binary_2(String, !.LastDigit, Len, Posn1, Token,
+ Context, !Posn)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ string_get_binary_2(String, !.LastDigit, Len, Posn1, Token,
+ Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn1, BinaryString, !Posn),
+ conv_string_to_int(BinaryString, base_2, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated binary literal")
+ ),
+ string_get_context(Posn1, Context, !Posn)
+ )
+ else
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn1, BinaryString, !Posn),
+ conv_string_to_int(BinaryString, base_2, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated binary literal")
+ ),
+ string_get_context(Posn1, Context, !Posn)
+ ).
+
+:- pred get_octal(io.input_stream::in, token::out, io::di, io::uo) is det.
+
+get_octal(Stream, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = error("unterminated octal literal")
+ ;
+ Result = ok,
+ ( if char.is_octal_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ get_octal_2(Stream, LastDigit, [Char], Token, !IO)
+ else if Char = '_' then
+ get_octal(Stream, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = error("unterminated octal literal")
+ )
+ ).
+
+:- pred string_get_octal(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_octal(String, Len, Posn0, Token, Context, !Posn) :-
+ Posn1 = !.Posn,
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_octal_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ string_get_octal_2(String, LastDigit, Len, Posn1, Token, Context,
+ !Posn)
+ else if Char = '_' then
+ string_get_octal(String, Len, Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ Token = error("unterminated octal literal"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ Token = error("unterminated octal literal"),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred get_octal_2(io.input_stream::in, last_digit_is_underscore::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_octal_2(Stream, !.LastDigit, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_8, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated octal literal")
+ )
+ ;
+ Result = ok,
+ ( if char.is_octal_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ !:LastDigit = last_digit_is_not_underscore,
+ get_octal_2(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ get_octal_2(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_8, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated octal literal")
+ )
+ )
+ ).
+
+:- pred string_get_octal_2(string::in, last_digit_is_underscore::in,
+ int::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_octal_2(String, !.LastDigit, Len, Posn1, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_octal_digit(Char) then
+ !:LastDigit = last_digit_is_not_underscore,
+ string_get_octal_2(String, !.LastDigit, Len, Posn1, Token, Context,
+ !Posn)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ string_get_octal_2(String, !.LastDigit, Len, Posn1, Token, Context,
+ !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn1, BinaryString, !Posn),
+ conv_string_to_int(BinaryString, base_8, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated octal literal")
+ ),
+ string_get_context(Posn1, Context, !Posn)
+ )
+ else
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn1, BinaryString, !Posn),
+ conv_string_to_int(BinaryString, base_8, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated octal literal")
+ ),
+ string_get_context(Posn1, Context, !Posn)
+ ).
+
+:- pred get_hex(io.input_stream::in, token::out, io::di, io::uo) is det.
+
+get_hex(Stream, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = error("unterminated hexadecimal literal")
+ ;
+ Result = ok,
+ ( if char.is_hex_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ get_hex_2(Stream, LastDigit, [Char], Token, !IO)
+ else if Char = '_' then
+ get_hex(Stream, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = error("unterminated hexadecimal literal")
+ )
+ ).
+
+:- pred string_get_hex(string::in, int::in, posn::in, token::out,
+ string_token_context::out, posn::in, posn::out) is det.
+
+string_get_hex(String, Len, Posn0, Token, Context, !Posn) :-
+ Posn1 = !.Posn,
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_hex_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ string_get_hex_2(String, LastDigit, Len, Posn1, Token, Context,
+ !Posn)
+ else if Char = '_' then
+ string_get_hex(String, Len, Posn0, Token, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ Token = error("unterminated hexadecimal literal"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ Token = error("unterminated hexadecimal literal"),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred get_hex_2(io.input_stream::in, last_digit_is_underscore::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_hex_2(Stream, !.LastDigit, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_16, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated hexadecimal literal")
+ )
+ ;
+ Result = ok,
+ ( if char.is_hex_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ !:LastDigit = last_digit_is_not_underscore,
+ get_hex_2(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ get_hex_2(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_16, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated hexadecimal literal")
+ )
+ )
+ ).
+
+:- pred string_get_hex_2(string::in, last_digit_is_underscore::in,
+ int::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_hex_2(String, !.LastDigit, Len, Posn1, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_hex_digit(Char) then
+ !:LastDigit = last_digit_is_not_underscore,
+ string_get_hex_2(String, !.LastDigit, Len, Posn1, Token, Context,
+ !Posn)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ string_get_hex_2(String, !.LastDigit, Len, Posn1, Token, Context,
+ !Posn)
+ else
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ string_ungetchar(String, !Posn),
+ grab_string(String, Posn1, BinaryString, !Posn),
+ conv_string_to_int(BinaryString, base_16, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated hexadecimal literal")
+ ),
+ string_get_context(Posn1, Context, !Posn)
+ )
+ else
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn1, BinaryString, !Posn),
+ conv_string_to_int(BinaryString, base_16, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated hexadecimal literal")
+ ),
+ string_get_context(Posn1, Context, !Posn)
+ ).
+
+:- pred get_number(io.input_stream::in, last_digit_is_underscore::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_number(Stream, !.LastDigit, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_10, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ )
+ ;
+ Result = ok,
+ ( if char.is_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ !:LastDigit = last_digit_is_not_underscore,
+ get_number(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ get_number(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = ('.') then
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ get_int_dot(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ )
+ else if ( Char = 'e' ; Char = 'E' ) then
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ !:RevChars = [Char | !.RevChars],
+ get_float_exponent(Stream, !.RevChars, Token, !IO)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("underscore before exponent")
+ )
+ else
+ io.putback_char(Stream, Char, !IO),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_10, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ )
+ )
+ ).
+
+:- pred string_get_number(string::in, last_digit_is_underscore::in,
+ int::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_number(String, !.LastDigit, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_digit(Char) then
+ !:LastDigit = last_digit_is_not_underscore,
+ string_get_number(String, !.LastDigit, Len, Posn0, Token, Context,
+ !Posn)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ string_get_number(String, !.LastDigit, Len, Posn0, Token, Context,
+ !Posn)
+ else if Char = ('.') then
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ string_get_int_dot(String, !.LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else if ( Char = 'e' ; Char = 'E' ) then
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ string_get_float_exponent(String, Len, Posn0, Token, Context,
+ !Posn)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("underscore before exponent"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ string_ungetchar(String, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn0, NumberString, !Posn),
+ conv_string_to_int(NumberString, base_10, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn0, NumberString, !Posn),
+ conv_string_to_int(NumberString, base_10, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred get_int_dot(io.input_stream::in, last_digit_is_underscore::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_int_dot(Stream, !.LastDigit, !.RevChars, Token, !IO) :-
+ % XXX The float literal syntax doesn't match ISO Prolog.
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ io.putback_char(Stream, '.', !IO),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_10, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ )
+ ;
+ Result = ok,
+ ( if char.is_digit(Char) then
+ !:RevChars = [Char, '.' | !.RevChars],
+ !:LastDigit = last_digit_is_not_underscore,
+ get_float_decimals(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = '_' then
+ Token = error("underscore following decimal point")
+ else
+ io.putback_char(Stream, Char, !IO),
+ % We can't putback the ".", because io.putback_char only
+ % guarantees one character of pushback. So instead, we return
+ % an `integer_dot' token; the main loop of get_token_list_2 will
+ % handle this appropriately.
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_int(!.RevChars, base_10, Token0),
+ ( if Token0 = integer(Int) then
+ Token = integer_dot(Int)
+ else
+ Token = Token0
+ )
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ )
+ )
+ ).
+
+:- pred string_get_int_dot(string::in, last_digit_is_underscore::in, int::in,
+ posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_int_dot(String, !.LastDigit, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_digit(Char) then
+ !:LastDigit = last_digit_is_not_underscore,
+ string_get_float_decimals(String, !.LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ else if Char = '_' then
+ Token = error("underscore following decimal point"),
+ string_get_context(Posn0, Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ string_ungetchar(String, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn0, NumberString, !Posn),
+ conv_string_to_int(NumberString, base_10, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ string_ungetchar(String, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_string(String, Posn0, NumberString, !Posn),
+ conv_string_to_int(NumberString, base_10, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated decimal literal")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+ % We have read past the decimal point, so now get the decimals.
+ %
+:- pred get_float_decimals(io.input_stream::in, last_digit_is_underscore::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_float_decimals(Stream, !.LastDigit, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_float(!.RevChars, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("fractional part of float terminated by underscore")
+ )
+ ;
+ Result = ok,
+ ( if char.is_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ !:LastDigit = last_digit_is_not_underscore,
+ get_float_decimals(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = '_' then
+ !:LastDigit= last_digit_is_underscore,
+ get_float_decimals(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if ( Char = 'e' ; Char = 'E' ) then
+ !:RevChars = [Char | !.RevChars],
+ get_float_exponent(Stream, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_float(!.RevChars, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token =
+ error("fractional part of float terminated by underscore")
+ )
+ )
+ ).
+
+:- pred string_get_float_decimals(string::in, last_digit_is_underscore::in,
+ int::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_float_decimals(String, !.LastDigit, Len, Posn0, Token, Context,
+ !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_digit(Char) then
+ !:LastDigit = last_digit_is_not_underscore,
+ string_get_float_decimals(String, !.LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ string_get_float_decimals(String, !.LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ else if ( Char = 'e' ; Char = 'E' ) then
+ string_get_float_exponent(String, Len, Posn0, Token, Context,
+ !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_float_string(String, Posn0, FloatString, !Posn),
+ conv_to_float(FloatString, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token =
+ error("fractional part of float terminated by underscore")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_float_string(String, Posn0, FloatString, !Posn),
+ conv_to_float(FloatString, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("fractional part of float terminated by underscore")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+:- pred get_float_exponent(io.input_stream::in, list(char)::in, token::out,
+ io::di, io::uo) is det.
+
+get_float_exponent(Stream, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ rev_char_list_to_float(!.RevChars, Token)
+ ;
+ Result = ok,
+ ( if ( Char = ('+') ; Char = ('-') ) then
+ !:RevChars = [Char | !.RevChars],
+ get_float_exponent_2(Stream, !.RevChars, Token, !IO)
+ else if char.is_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ LastDigit = last_digit_is_not_underscore,
+ get_float_exponent_3(Stream, LastDigit, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = error("unterminated exponent in float literal")
+ )
+ ).
+
+:- pred string_get_float_exponent(string::in, int::in, posn::in,
+ token::out, string_token_context::out, posn::in, posn::out) is det.
+
+string_get_float_exponent(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if ( Char = ('+') ; Char = ('-') ) then
+ string_get_float_exponent_2(String, Len, Posn0, Token, Context,
+ !Posn)
+ else if char.is_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ string_get_float_exponent_3(String, LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ Token = error("unterminated exponent in float literal"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ grab_float_string(String, Posn0, FloatString, !Posn),
+ conv_to_float(FloatString, Token),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+ % We have read past the E signalling the start of the exponent -
+ % make sure that there's at least one digit following,
+ % and then get the remaining digits.
+ %
+:- pred get_float_exponent_2(io.input_stream::in, list(char)::in, token::out,
+ io::di, io::uo) is det.
+
+get_float_exponent_2(Stream, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ Token = error("unterminated exponent in float literal")
+ ;
+ Result = ok,
+ ( if char.is_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ LastDigit = last_digit_is_not_underscore,
+ get_float_exponent_3(Stream, LastDigit, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ Token = error("unterminated exponent in float literal")
+ )
+ ).
+
+ % We have read past the E signalling the start of the exponent -
+ % make sure that there's at least one digit following,
+ % and then get the remaining digits.
+ %
+:- pred string_get_float_exponent_2(string::in, int::in, posn::in,
+ token::out, string_token_context::out, posn::in, posn::out) is det.
+
+string_get_float_exponent_2(String, Len, Posn0, Token, Context, !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_digit(Char) then
+ LastDigit = last_digit_is_not_underscore,
+ string_get_float_exponent_3(String, LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ Token = error("unterminated exponent in float literal"),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ Token = error("unterminated exponent in float literal"),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+ % We have read past the first digit of the exponent -
+ % now get the remaining digits.
+ %
+:- pred get_float_exponent_3(io.input_stream::in, last_digit_is_underscore::in,
+ list(char)::in, token::out, io::di, io::uo) is det.
+
+get_float_exponent_3(Stream, !.LastDigit, !.RevChars, Token, !IO) :-
+ io.read_char_unboxed(Stream, Result, Char, !IO),
+ (
+ Result = error(Error),
+ Token = io_error(Error)
+ ;
+ Result = eof,
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_float(!.RevChars, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated exponent in float literal")
+ )
+ ;
+ Result = ok,
+ ( if char.is_digit(Char) then
+ !:RevChars = [Char | !.RevChars],
+ !:LastDigit = last_digit_is_not_underscore,
+ get_float_exponent_3(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ get_float_exponent_3(Stream, !.LastDigit, !.RevChars, Token, !IO)
+ else
+ io.putback_char(Stream, Char, !IO),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ rev_char_list_to_float(!.RevChars, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated exponent in float literal")
+ )
+ )
+ ).
+
+:- pred string_get_float_exponent_3(string::in, last_digit_is_underscore::in,
+ int::in, posn::in, token::out, string_token_context::out,
+ posn::in, posn::out) is det.
+
+string_get_float_exponent_3(String, !.LastDigit, Len, Posn0, Token, Context,
+ !Posn) :-
+ ( if string_read_char(String, Len, Char, !Posn) then
+ ( if char.is_digit(Char) then
+ !:LastDigit = last_digit_is_not_underscore,
+ string_get_float_exponent_3(String, !.LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ else if Char = '_' then
+ !:LastDigit = last_digit_is_underscore,
+ string_get_float_exponent_3(String, !.LastDigit, Len, Posn0, Token,
+ Context, !Posn)
+ else
+ string_ungetchar(String, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ grab_float_string(String, Posn0, FloatString, !Posn),
+ conv_to_float(FloatString, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated exponent in float literal")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ )
+ else
+ grab_float_string(String, Posn0, FloatString, !Posn),
+ (
+ !.LastDigit = last_digit_is_not_underscore,
+ conv_to_float(FloatString, Token)
+ ;
+ !.LastDigit = last_digit_is_underscore,
+ Token = error("unterminated exponent in float literal")
+ ),
+ string_get_context(Posn0, Context, !Posn)
+ ).
+
+%---------------------------------------------------------------------------%
+%
+% Utility routines.
+%
+
+:- pred rev_char_list_to_int(list(char)::in, integer_base::in, token::out)
+ is det.
+
+rev_char_list_to_int(RevChars, Base, Token) :-
+ ( if rev_char_list_to_string(RevChars, String) then
+ conv_string_to_int(String, Base, Token)
+ else
+ Token = error("invalid character in int")
+ ).
+
+:- pred conv_string_to_int(string::in, integer_base::in, token::out) is det.
+
+conv_string_to_int(String, Base, Token) :-
+ BaseInt = integer_base_int(Base),
+ ( if string.base_string_to_int_underscore(BaseInt, String, Int) then
+ Token = integer(Int)
+ else if integer.from_base_string_underscore(BaseInt, String, Integer) then
+ Token = big_integer(Base, Integer)
+ else
+ Token = error("invalid character in int")
+ ).
+
+:- func integer_base_int(integer_base) = int.
+
+integer_base_int(base_2) = 2.
+integer_base_int(base_8) = 8.
+integer_base_int(base_10) = 10.
+integer_base_int(base_16) = 16.
+
+:- pred rev_char_list_to_float(list(char)::in, token::out) is det.
+
+rev_char_list_to_float(RevChars, Token) :-
+ ( if rev_char_list_to_string(RevChars, String) then
+ conv_to_float(String, Token)
+ else
+ Token = error("invalid character in int")
+ ).
+
+:- pred conv_to_float(string::in, token::out) is det.
+
+conv_to_float(String, Token) :-
+ ( if string.to_float(String, Float) then
+ Token = float(Float)
+ else
+ Token = error("invalid float token")
+ ).
+
+:- pred rev_char_list_to_string(list(char)::in, string::out) is semidet.
+
+rev_char_list_to_string(RevChars, String) :-
+ string.semidet_from_rev_char_list(RevChars, String).
+
+:- func null_character_error = token.
+
+null_character_error =
+ error("null character is illegal in strings and names").
+
+%---------------------------------------------------------------------------%
+
+token_to_string(Token, String) :-
+ (
+ Token = name(Name),
+ string.append_list(["token '", Name, "'"], String)
+ ;
+ Token = variable(Var),
+ string.append_list(["variable `", Var, "'"], String)
+ ;
+ Token = integer(Int),
+ string.int_to_string(Int, IntString),
+ string.append_list(["integer `", IntString, "'"], String)
+ ;
+ Token = big_integer(Base, Integer),
+ (
+ Base = base_2,
+ BaseInt = 2,
+ Prefix = "0b"
+ ;
+ Base = base_8,
+ BaseInt = 8,
+ Prefix = "0o"
+ ;
+ Base = base_10,
+ BaseInt = 10,
+ Prefix = ""
+ ;
+ Base = base_16,
+ BaseInt = 16,
+ Prefix = "0x"
+ ),
+ IntString = integer.to_base_string(Integer, BaseInt),
+ string.append_list(["integer `", Prefix, IntString, "'"], String)
+ ;
+ Token = float(Float),
+ string.float_to_string(Float, FloatString),
+ string.append_list(["float `", FloatString, "'"], String)
+ ;
+ Token = string(TokenString),
+ string.append_list(["string """, TokenString, """"], String)
+ ;
+ Token = implementation_defined(Name),
+ string.append_list(["implementation-defined `$", Name, "'"], String)
+ ;
+ Token = open,
+ String = "token ` ('"
+ ;
+ Token = open_ct,
+ String = "token `('"
+ ;
+ Token = close,
+ String = "token `)'"
+ ;
+ Token = open_list,
+ String = "token `['"
+ ;
+ Token = close_list,
+ String = "token `]'"
+ ;
+ Token = open_curly,
+ String = "token `{'"
+ ;
+ Token = close_curly,
+ String = "token `}'"
+ ;
+ Token = ht_sep,
+ String = "token `|'"
+ ;
+ Token = comma,
+ String = "token `,'"
+ ;
+ Token = end,
+ String = "token `. '"
+ ;
+ Token = eof,
+ String = "end-of-file"
+ ;
+ Token = junk(JunkChar),
+ char.to_int(JunkChar, Code),
+ string.int_to_base_string(Code, 16, Hex),
+ string.append_list(["illegal character <<0x", Hex, ">>"], String)
+ ;
+ Token = io_error(IO_Error),
+ io.error_message(IO_Error, IO_ErrorMessage),
+ string.append("I/O error: ", IO_ErrorMessage, String)
+ ;
+ Token = error(Message),
+ string.append_list(["illegal token (", Message, ")"], String)
+ ;
+ Token = integer_dot(Int),
+ string.int_to_string(Int, IntString),
+ string.append_list(["integer `", IntString, "'."], String)
+ ).
+
+%---------------------------------------------------------------------------%
diff --git a/extras/old_term_parser/old_parser.m b/extras/old_term_parser/old_parser.m
index e69de29..5f436dd 100644
--- a/extras/old_term_parser/old_parser.m
+++ b/extras/old_term_parser/old_parser.m
@@ -0,0 +1,1245 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%---------------------------------------------------------------------------%
+% Copyright (C) 1995-2001, 2003-2008, 2011-2012 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% File: old_parser.m.
+% Main author: fjh.
+% Stability: high.
+%
+% This file exports the predicate read_term, which reads
+% a term from the current input stream.
+% The read_term_from_string predicates are the same as the
+% read_term predicates, except that the term is read from
+% a string rather than from the current input stream.
+% The parse_token_list predicate is similar,
+% but it takes a list of tokens rather than a string.
+%
+% The parser and lexer are intended to exactly follow ISO Prolog
+% syntax, but there are some departures from that for three reasons:
+%
+% (1) I wrote some of the code at home when the ISO Prolog draft
+% was at uni - so in some places I just guessed.
+% (2) In some places the lexer reports an error when it shouldn't.
+% (3) There are a couple of hacks to make it compatible with NU-Prolog
+% syntax.
+%
+% The parser is a relatively straight-forward top-down recursive descent
+% parser, made somewhat complicated by the need to handle operator
+% precedences. It uses `old_lexer.get_token_list' to read a list of tokens.
+% It uses the routines in module `ops' to look up operator precedences.
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module old_parser.
+:- interface.
+
+:- import_module io.
+:- import_module old_lexer.
+:- import_module ops.
+:- import_module old_term_io.
+
+%---------------------------------------------------------------------------%
+
+ % read_term(Result, !IO):
+ % read_term(Stream, Result, !IO):
+ %
+ % Reads a Mercury term from the current input stream or from Stream.
+ %
+:- pred read_term(read_term(T)::out, io::di, io::uo) is det.
+:- pred read_term(io.text_input_stream::in, read_term(T)::out,
+ io::di, io::uo) is det.
+
+ % read_term_with_op_table(Ops, Result, !IO):
+ % read_term_with_op_table(Stream, Ops, Result, !IO):
+ %
+ % Reads a term from the current input stream or from Stream,
+ % using the given op_table to interpret the operators.
+ %
+:- pred read_term_with_op_table(Ops::in,
+ read_term(T)::out, io::di, io::uo) is det <= op_table(Ops).
+:- pred read_term_with_op_table(io.text_input_stream::in, Ops::in,
+ read_term(T)::out, io::di, io::uo) is det <= op_table(Ops).
+
+ % read_term_filename(FileName, Result, !IO):
+ % read_term_filename(Stream, FileName, Result, !IO):
+ %
+ % Reads a term from the current input stream or from Stream.
+ % The string is the filename to use for the stream; this is used
+ % in constructing the old_term.contexts in the read term.
+ % This interface is used to support the `:- pragma source_file' directive.
+ %
+:- pred read_term_filename(string::in,
+ read_term(T)::out, io::di, io::uo) is det.
+:- pred read_term_filename(io.text_input_stream::in, string::in,
+ read_term(T)::out, io::di, io::uo) is det.
+
+ % read_term_filename_with_op_table(Ops, FileName, Result, !IO):
+ % read_term_filename_with_op_table(Stream, Ops, FileName, Result, !IO):
+ %
+ % As above but using the given op_table.
+ %
+:- pred read_term_filename_with_op_table(Ops::in,
+ string::in, read_term(T)::out, io::di, io::uo) is det <= op_table(Ops).
+:- pred read_term_filename_with_op_table(io.text_input_stream::in, Ops::in,
+ string::in, read_term(T)::out, io::di, io::uo) is det <= op_table(Ops).
+
+%---------------------------------------------------------------------------%
+
+ % The read_term_from_string predicates are the same as the read_term
+ % predicates, except that the term is read from a string rather than from
+ % the current input stream. The returned value `EndPos' is the position
+ % one character past the end of the term read. The arguments `MaxOffset'
+ % and `StartPos' in the six-argument version specify the length of the
+ % string and the position within the string at which to start parsing.
+
+ % read_term_from_string(FileName, String, EndPos, Term).
+ %
+:- pred read_term_from_string(string::in, string::in, posn::out,
+ read_term(T)::out) is det.
+
+ % read_term_from_string_with_op_table(Ops, FileName,
+ % String, EndPos, Term).
+ %
+:- pred read_term_from_string_with_op_table(Ops::in, string::in,
+ string::in, posn::out, read_term(T)::out) is det <= op_table(Ops).
+
+ % read_term_from_string(FileName, String, MaxOffset, StartPos,
+ % EndPos, Term).
+ %
+:- pred read_term_from_substring(string::in, string::in, int::in,
+ posn::in, posn::out, read_term(T)::out) is det.
+
+ % read_term_from_string_with_op_table(Ops, FileName, String,
+ % MaxOffset, StartPos, EndPos, Term).
+ %
+:- pred read_term_from_substring_with_op_table(Ops::in, string::in,
+ string::in, int::in, posn::in, posn::out, read_term(T)::out) is det
+ <= op_table(Ops).
+
+%---------------------------------------------------------------------------%
+
+ % parse_tokens(FileName, TokenList, Result):
+ %
+:- pred parse_tokens(string::in, token_list::in, read_term(T)::out) is det.
+
+ % parse_tokens(FileName, TokenList, Result):
+ %
+:- pred parse_tokens_with_op_table(Ops::in, string::in, token_list::in,
+ read_term(T)::out) is det <= op_table(Ops).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module bool.
+:- import_module char.
+:- import_module float.
+:- import_module int.
+:- import_module integer.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module require.
+:- import_module string.
+:- import_module old_term.
+:- import_module old_varset.
+
+%---------------------------------------------------------------------------%
+
+:- type parse(T)
+ ---> ok(T)
+ ; error(string, token_list).
+
+ % Are we parsing an ordinary term, an argument or a list element?
+:- type term_kind
+ ---> ordinary_term
+ ; argument
+ ; list_elem.
+
+%---------------------------------------------------------------------------%
+
+read_term(Result, !IO) :-
+ io.input_stream(Stream, !IO),
+ old_parser.read_term(Stream, Result, !IO).
+
+read_term(Stream, Result, !IO) :-
+ io.input_stream_name(Stream, FileName, !IO),
+ old_parser.read_term_filename_with_op_table(Stream, ops.init_mercury_op_table,
+ FileName, Result, !IO).
+
+read_term_with_op_table(Ops, Result, !IO) :-
+ io.input_stream(Stream, !IO),
+ old_parser.read_term_with_op_table(Stream, Ops, Result, !IO).
+
+read_term_with_op_table(Stream, Ops, Result, !IO) :-
+ io.input_stream_name(Stream, FileName, !IO),
+ old_parser.read_term_filename_with_op_table(Stream, Ops,
+ FileName, Result, !IO).
+
+read_term_filename(FileName, Result, !IO) :-
+ io.input_stream(Stream, !IO),
+ old_parser.read_term_filename(Stream, FileName, Result, !IO).
+
+read_term_filename(Stream, FileName, Result, !IO) :-
+ old_parser.read_term_filename_with_op_table(Stream, ops.init_mercury_op_table,
+ FileName, Result, !IO).
+
+read_term_filename_with_op_table(Ops, FileName, Result, !IO) :-
+ io.input_stream(Stream, !IO),
+ old_parser.read_term_filename_with_op_table(Stream, Ops,
+ FileName, Result, !IO).
+
+read_term_filename_with_op_table(Stream, Ops, FileName, Result, !IO) :-
+ old_lexer.get_token_list(Stream, Tokens, !IO),
+ old_parser.parse_tokens_with_op_table(Ops, FileName, Tokens, Result).
+
+%---------------------%
+
+read_term_from_string(FileName, String, EndPos, Result) :-
+ old_parser.read_term_from_string_with_op_table(ops.init_mercury_op_table,
+ FileName, String, EndPos, Result).
+
+read_term_from_string_with_op_table(Ops, FileName, String, EndPos, Result) :-
+ string.length(String, Len),
+ StartPos = posn(1, 0, 0),
+ old_parser.read_term_from_substring_with_op_table(Ops, FileName, String, Len,
+ StartPos, EndPos, Result).
+
+read_term_from_substring(FileName, String, Len, StartPos, EndPos, Result) :-
+ old_parser.read_term_from_substring_with_op_table(ops.init_mercury_op_table,
+ FileName, String, Len, StartPos, EndPos, Result).
+
+read_term_from_substring_with_op_table(Ops, FileName, String, Len,
+ StartPos, EndPos, Result) :-
+ old_lexer.string_get_token_list_max(String, Len, Tokens, StartPos, EndPos),
+ old_parser.parse_tokens_with_op_table(Ops, FileName, Tokens, Result).
+
+%---------------------------------------------------------------------------%
+
+parse_tokens(FileName, Tokens, Result) :-
+ old_parser.parse_tokens_with_op_table(ops.init_mercury_op_table,
+ FileName, Tokens, Result).
+
+parse_tokens_with_op_table(Ops, FileName, Tokens, Result) :-
+ (
+ Tokens = token_nil,
+ Result = eof
+ ;
+ Tokens = token_cons(_, _, _),
+ init_parser_state(Ops, FileName, ParserState0),
+ parse_whole_term(Term, Tokens, LeftOverTokens,
+ ParserState0, ParserState),
+ final_parser_state(ParserState, VarSet),
+ check_for_errors(Term, VarSet, Tokens, LeftOverTokens, Result)
+ ).
+
+:- pred check_for_errors(parse(term(T))::in, varset(T)::in,
+ token_list::in, token_list::in, read_term(T)::out) is det.
+
+check_for_errors(Parse, VarSet, Tokens, LeftOverTokens, Result) :-
+ (
+ Parse = error(ErrorMessage, ErrorTokens),
+ % Check if the error was caused by a bad token.
+ ( if check_for_bad_token(Tokens, BadTokenMessage, BadTokenLineNum) then
+ Message = BadTokenMessage,
+ LineNum = BadTokenLineNum
+ else
+ % Find the token that caused the error.
+ (
+ ErrorTokens = token_cons(ErrorTok, ErrorTokLineNum, _),
+ old_lexer.token_to_string(ErrorTok, TokString),
+ Message =
+ "Syntax error at " ++ TokString ++ ": " ++ ErrorMessage,
+ LineNum = ErrorTokLineNum
+ ;
+ ErrorTokens = token_nil,
+ (
+ Tokens = token_cons(_, LineNum, _)
+ ;
+ Tokens = token_nil,
+ error("check_for_errors")
+ ),
+ Message = "Syntax error: " ++ ErrorMessage
+ )
+ ),
+ Result = error(Message, LineNum)
+ ;
+ Parse = ok(Term),
+ ( if check_for_bad_token(Tokens, Message, LineNum) then
+ Result = error(Message, LineNum)
+ else
+ (
+ LeftOverTokens = token_cons(Token, LineNum, _),
+ old_lexer.token_to_string(Token, TokString),
+ Message = "Syntax error: unexpected " ++ TokString,
+ Result = error(Message, LineNum)
+ ;
+ LeftOverTokens = token_nil,
+ Result = term(VarSet, Term)
+ )
+ )
+ ).
+
+:- pred check_for_bad_token(token_list::in, string::out, int::out) is semidet.
+
+check_for_bad_token(token_cons(Token, LineNum0, Tokens), Message, LineNum) :-
+ require_complete_switch [Token]
+ (
+ Token = io_error(IO_Error),
+ io.error_message(IO_Error, IO_ErrorMessage),
+ string.append("I/O error: ", IO_ErrorMessage, Message),
+ LineNum = LineNum0
+ ;
+ Token = junk(Char),
+ char.to_int(Char, Code),
+ string.int_to_base_string(Code, 10, Decimal),
+ string.int_to_base_string(Code, 16, Hex),
+ string.append_list(["Syntax error: Illegal character 0x", Hex,
+ " (", Decimal, ") in input"], Message),
+ LineNum = LineNum0
+ ;
+ Token = error(ErrorMessage),
+ string.append("Syntax error: ", ErrorMessage, Message),
+ LineNum = LineNum0
+ ;
+ ( Token = name(_)
+ ; Token = variable(_)
+ ; Token = integer(_)
+ ; Token = big_integer(_, _)
+ ; Token = float(_)
+ ; Token = string(_)
+ ; Token = implementation_defined(_)
+ ; Token = open
+ ; Token = open_ct
+ ; Token = close
+ ; Token = open_list
+ ; Token = close_list
+ ; Token = open_curly
+ ; Token = close_curly
+ ; Token = ht_sep
+ ; Token = comma
+ ; Token = end
+ ; Token = eof
+ ; Token = integer_dot(_)
+ ),
+ check_for_bad_token(Tokens, Message, LineNum)
+ ).
+check_for_bad_token(token_nil, _, _) :-
+ fail.
+
+:- pred parse_whole_term(parse(term(T))::out,
+ token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_whole_term(Term, !TokensLeft, !PS) :-
+ parse_term(Term0, !TokensLeft, !PS),
+ (
+ Term0 = ok(_),
+ ( if !.TokensLeft = token_cons(end, _Context, !:TokensLeft) then
+ Term = Term0
+ else
+ parser_unexpected("operator or `.' expected", Term,
+ !TokensLeft, !.PS)
+ )
+ ;
+ % Propagate error upwards.
+ Term0 = error(_, _),
+ Term = Term0
+ ).
+
+:- pred parse_term(parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_term(Term, !TokensLeft, !PS) :-
+ OpTable = parser_state_get_ops_table(!.PS),
+ do_parse_term(ops.max_priority(OpTable) + 1, ordinary_term, Term,
+ !TokensLeft, !PS).
+
+:- pred parse_arg(parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_arg(Term, !TokensLeft, !PS) :-
+ OpTable = parser_state_get_ops_table(!.PS),
+ % XXX We should do the following:
+ % ArgPriority = ops.arg_priority(OpTable),
+ % but that would mean we can't, for example, parse '::'/2 in arguments
+ % the way we want to. Perhaps a better solution would be to change the
+ % priority of '::'/2, but we need to analyse the impact of that further.
+ ArgPriority = ops.max_priority(OpTable) + 1,
+ do_parse_term(ArgPriority, argument, Term, !TokensLeft, !PS).
+
+:- pred parse_list_elem(parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_list_elem(Term, !TokensLeft, !PS) :-
+ OpTable = parser_state_get_ops_table(!.PS),
+ % XXX We should do the following:
+ % ArgPriority = ops.arg_priority(OpTable),
+ % but that would mean we can't, for example, parse promise_pure/0 in
+ % foreign attribute lists.
+ ArgPriority = ops.max_priority(OpTable) + 1,
+ do_parse_term(ArgPriority, list_elem, Term, !TokensLeft, !PS).
+
+:- pred do_parse_term(int::in, term_kind::in, parse(term(T))::out,
+ token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+do_parse_term(MaxPriority, TermKind, Term, !TokensLeft, !PS) :-
+ parse_left_term(MaxPriority, TermKind, LeftPriority, LeftTerm0,
+ !TokensLeft, !PS),
+ (
+ LeftTerm0 = ok(LeftTerm),
+ parse_rest(MaxPriority, TermKind, LeftPriority, LeftTerm, Term,
+ !TokensLeft, !PS)
+ ;
+ LeftTerm0 = error(_, _),
+ % propagate error upwards
+ Term = LeftTerm0
+ ).
+
+:- pred parse_left_term(int::in, term_kind::in, int::out, parse(term(T))::out,
+ token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_left_term(MaxPriority, TermKind, OpPriority, Term, !TokensLeft, !PS) :-
+ (
+ !.TokensLeft = token_cons(Token, Context, !:TokensLeft),
+ ( if
+ % Check for unary minus of an integer or a float.
+ Token = name(TokenName),
+ TokenName = "-",
+ !.TokensLeft =
+ token_cons(NextToken, _NextContext, !:TokensLeft),
+ (
+ NextToken = integer(X),
+ NegX = 0 - X,
+ NewFunctor = integer(NegX)
+ ;
+ NextToken = big_integer(_, X),
+ -X = integer(min_int),
+ NegX = int.min_int,
+ NewFunctor = integer(NegX)
+ ;
+ NextToken = float(F),
+ NegF = 0.0 - F,
+ NewFunctor = float(NegF)
+ )
+ then
+ parser_get_term_context(!.PS, Context, TermContext),
+ Term = ok(old_term.functor(NewFunctor, [], TermContext)),
+ OpPriority = 0
+ else if
+ Token = name(TokenName),
+ OpTable = parser_state_get_ops_table(!.PS),
+ ops.lookup_op_infos(OpTable, TokenName, OpInfo, OtherOpInfos)
+ then
+ ( if
+ % Check for binary prefix op.
+ %
+ % Since most tokens aren't binary prefix ops, the first test
+ % here will almost always fail.
+ find_first_binary_prefix_op(OpInfo, OtherOpInfos,
+ BinOpPriority, RightAssoc, RightRightAssoc),
+ BinOpPriority =< MaxPriority,
+ !.TokensLeft = token_cons(NextToken, _, _),
+ could_start_term(NextToken, yes),
+ NextToken \= open_ct
+
+ then
+ OpPriority = BinOpPriority,
+ adjust_priority_for_assoc(OpPriority,
+ RightAssoc, RightPriority),
+ adjust_priority_for_assoc(OpPriority,
+ RightRightAssoc, RightRightPriority),
+ do_parse_term(RightPriority, TermKind, RightResult,
+ !TokensLeft, !PS),
+ (
+ RightResult = ok(RightTerm),
+ do_parse_term(RightRightPriority, TermKind,
+ RightRightResult, !TokensLeft, !PS),
+ (
+ RightRightResult = ok(RightRightTerm),
+ parser_get_term_context(!.PS, Context, TermContext),
+ Term = ok(old_term.functor(old_term.atom(TokenName),
+ [RightTerm, RightRightTerm], TermContext))
+ ;
+ RightRightResult = error(_, _),
+ % Propagate error upwards.
+ Term = RightRightResult
+ )
+ ;
+ RightResult = error(_, _),
+ % Propagate error upwards.
+ Term = RightResult
+ )
+ else if
+ % Check for prefix op.
+ %
+ % Since most tokens aren't prefix ops, the first test
+ % here will almost always fail.
+ find_first_prefix_op(OpInfo, OtherOpInfos,
+ UnOpPriority, RightAssoc),
+ UnOpPriority =< MaxPriority,
+ !.TokensLeft = token_cons(NextToken, _, _),
+ could_start_term(NextToken, yes),
+ NextToken \= open_ct
+ then
+ OpPriority = UnOpPriority,
+ adjust_priority_for_assoc(OpPriority, RightAssoc,
+ RightPriority),
+ do_parse_term(RightPriority, TermKind, RightResult,
+ !TokensLeft, !PS),
+ (
+ RightResult = ok(RightTerm),
+ parser_get_term_context(!.PS, Context, TermContext),
+ Term = ok(old_term.functor(old_term.atom(TokenName), [RightTerm],
+ TermContext))
+ ;
+ RightResult = error(_, _),
+ % Propagate error upwards.
+ Term = RightResult
+ )
+ else
+ % TokenName is an operator, but not of a kind that
+ % we should handle here.
+ parse_simple_term(Token, Context, MaxPriority, Term,
+ !TokensLeft, !PS),
+ OpPriority = 0
+ )
+ else
+ % TokenName is not an operator.
+ parse_simple_term(Token, Context, MaxPriority, Term,
+ !TokensLeft, !PS),
+ OpPriority = 0
+ )
+ ;
+ !.TokensLeft = token_nil,
+ Term = error("unexpected end-of-file at start of sub-term",
+ !.TokensLeft),
+ OpPriority = 0
+ ).
+
+:- pred parse_rest(int::in, term_kind::in, int::in, term(T)::in,
+ parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_rest(MaxPriority, TermKind, LeftPriority, LeftTerm, Term,
+ !TokensLeft, !PS) :-
+ ( if
+ % Infix op.
+ !.TokensLeft = token_cons(Token, Context, !:TokensLeft),
+ (
+ Token = comma,
+ TermKind = ordinary_term,
+ Op0 = ","
+ ;
+ Token = ht_sep,
+ TermKind \= list_elem,
+ Op0 = "|"
+ ;
+ Token = name(Op0)
+ ),
+ ( if
+ % A token surrounded by backquotes is a prefix token being used
+ % in an infix manner.
+ Op0 = "`",
+ OpTable = parser_state_get_ops_table(!.PS),
+ ops.lookup_operator_term(OpTable, OpPriority0,
+ LeftAssoc0, RightAssoc0)
+ then
+ OpPriority = OpPriority0,
+ LeftAssoc = LeftAssoc0,
+ RightAssoc = RightAssoc0,
+ parse_backquoted_operator(MaybeQualifier, Op, VariableTerms,
+ !TokensLeft, !PS),
+ !.TokensLeft = token_cons(name("`"), _Context, !:TokensLeft)
+ else
+ Op = Op0,
+ VariableTerms = [],
+ MaybeQualifier = no,
+ OpTable = parser_state_get_ops_table(!.PS),
+ ops.lookup_infix_op(OpTable, Op, OpPriority, LeftAssoc, RightAssoc)
+ ),
+ OpPriority =< MaxPriority,
+ check_priority(LeftAssoc, OpPriority, LeftPriority)
+ then
+ adjust_priority_for_assoc(OpPriority, RightAssoc, RightPriority),
+ do_parse_term(RightPriority, TermKind, RightTerm0, !TokensLeft, !PS),
+ (
+ RightTerm0 = ok(RightTerm),
+ parser_get_term_context(!.PS, Context, TermContext),
+ OpTermArgs0 = VariableTerms ++ [LeftTerm, RightTerm],
+ OpTerm0 = old_term.functor(old_term.atom(Op), OpTermArgs0, TermContext),
+ (
+ MaybeQualifier = no,
+ OpTerm = OpTerm0
+ ;
+ MaybeQualifier = yes(QTerm),
+ OpTerm = old_term.functor(old_term.atom("."), [QTerm, OpTerm0],
+ TermContext)
+ ),
+ parse_rest(MaxPriority, TermKind, OpPriority, OpTerm, Term,
+ !TokensLeft, !PS)
+ ;
+ RightTerm0 = error(_, _),
+ % Propagate error upwards.
+ Term = RightTerm0
+ )
+ else if
+ % Postfix op.
+ !.TokensLeft = token_cons(name(Op), Context, !:TokensLeft),
+ OpTable = parser_state_get_ops_table(!.PS),
+ ops.lookup_postfix_op(OpTable, Op, OpPriority, LeftAssoc),
+ OpPriority =< MaxPriority,
+ check_priority(LeftAssoc, OpPriority, LeftPriority)
+ then
+ parser_get_term_context(!.PS, Context, TermContext),
+ OpTerm = old_term.functor(old_term.atom(Op), [LeftTerm], TermContext),
+ parse_rest(MaxPriority, TermKind, OpPriority, OpTerm, Term,
+ !TokensLeft, !PS)
+ else
+ Term = ok(LeftTerm)
+ ).
+
+:- pred parse_backquoted_operator(maybe(term(T))::out, string::out,
+ list(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is semidet
+ <= op_table(Ops).
+
+parse_backquoted_operator(MaybeQualifier, OpName, VariableTerms,
+ !TokensLeft, !PS) :-
+ !.TokensLeft = token_cons(Token, Context, !:TokensLeft),
+ parser_get_term_context(!.PS, Context, TermContext),
+ (
+ Token = variable(VariableOp),
+ MaybeQualifier = no,
+ OpName = "",
+ add_var(VariableOp, Var, !PS),
+ VariableTerms = [variable(Var, TermContext)]
+ ;
+ Token = name(OpName0),
+ VariableTerms = [],
+ parse_backquoted_operator_qualifier(no, MaybeQualifier, TermContext,
+ OpName0, OpName, !TokensLeft, !PS)
+ ).
+
+:- pred parse_backquoted_operator_qualifier(
+ maybe(term(T))::in, maybe(term(T))::out, old_term.context::in, string::in,
+ string::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_backquoted_operator_qualifier(MaybeQualifier0, MaybeQualifier, OpCtxt0,
+ OpName0, OpName, !TokensLeft, !PS) :-
+ ( if
+ !.TokensLeft =
+ token_cons(name(ModuleSeparator), SepContext, !:TokensLeft),
+ ( ModuleSeparator = "."
+ ; ModuleSeparator = ":"
+ ),
+ !.TokensLeft = token_cons(name(OpName1), NameContext, !:TokensLeft),
+ OpName1 \= "`"
+ then
+ QTerm1 = old_term.functor(atom(OpName0), [], OpCtxt0),
+ (
+ MaybeQualifier0 = no,
+ MaybeQualifier01 = yes(QTerm1)
+ ;
+ MaybeQualifier0 = yes(QTerm0),
+ parser_get_term_context(!.PS, SepContext, SepCtxt),
+ QTerm01 = functor(atom("."), [QTerm0, QTerm1], SepCtxt),
+ MaybeQualifier01 = yes(QTerm01)
+ ),
+ parser_get_term_context(!.PS, NameContext, OpCtxt1),
+ parse_backquoted_operator_qualifier(MaybeQualifier01, MaybeQualifier,
+ OpCtxt1, OpName1, OpName, !TokensLeft, !PS)
+ else
+ MaybeQualifier = MaybeQualifier0,
+ OpName = OpName0
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % term --> integer % priority 0
+ % term --> float % priority 0
+ % term --> implementation_defined % priority 0
+ % term --> name("-") integer % priority 0
+ % term --> name("-") float % priority 0
+ % term --> atom(NonOp) % priority 0
+ % term --> atom(Op) % priority `max_priority' + 1
+ % atom --> name
+ % atom --> open_list, close_list
+ % atom --> open_curly, close_curly
+ % term --> variable % priority 0
+ % term --> atom, open_ct, arg_list, close
+ % arg_list --> arg
+ % arg_list --> arg, comma, arg_list
+ % term --> open, term, close
+ % term --> open_ct, term, close
+ % term --> term, op, term % with various conditions
+ % term --> op, term % with various conditions
+ % term --> term, op % with various conditions
+
+:- pred parse_simple_term(token::in, token_context::in, int::in,
+ parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_simple_term(Token, Context, Prec, TermParse, !TokensLeft, !PS) :-
+ (
+ Token = name(Atom),
+ parser_get_term_context(!.PS, Context, TermContext),
+ ( if !.TokensLeft = token_cons(open_ct, _Context, !:TokensLeft) then
+ parse_args(ArgsParse, !TokensLeft, !PS),
+ (
+ ArgsParse = ok(Args),
+ BaseTerm = functor(atom(Atom), Args, TermContext),
+ BaseTermParse = ok(BaseTerm)
+ ;
+ ArgsParse = error(Message, Tokens),
+ % Propagate error upwards, after changing type.
+ BaseTermParse = error(Message, Tokens)
+ )
+ else
+ OpTable = parser_state_get_ops_table(!.PS),
+ ( if
+ ops.lookup_op(OpTable, Atom),
+ Prec =< ops.max_priority(OpTable)
+ then
+ parser_unexpected_tok(Token, Context,
+ "unexpected token at start of (sub)term",
+ BaseTermParse, !TokensLeft, !.PS)
+ else
+ BaseTerm = functor(atom(Atom), [], TermContext),
+ BaseTermParse = ok(BaseTerm)
+ )
+ )
+ ;
+ Token = variable(VarName),
+ add_var(VarName, Var, !PS),
+ parser_get_term_context(!.PS, Context, TermContext),
+ BaseTerm = old_term.variable(Var, TermContext),
+ BaseTermParse = ok(BaseTerm)
+ ;
+ Token = integer(Int),
+ parser_get_term_context(!.PS, Context, TermContext),
+ BaseTerm = functor(integer(Int), [], TermContext),
+ BaseTermParse = ok(BaseTerm)
+ ;
+ Token = big_integer(LexerBase, String),
+ parser_get_term_context(!.PS, Context, TermContext),
+ (
+ LexerBase = base_2,
+ TermBase = base_2
+ ;
+ LexerBase = base_8,
+ TermBase = base_8
+ ;
+ LexerBase = base_10,
+ TermBase = base_10
+ ;
+ LexerBase = base_16,
+ TermBase = base_16
+ ),
+ BaseTerm = functor(big_integer(TermBase, String), [], TermContext),
+ BaseTermParse = ok(BaseTerm)
+ ;
+ Token = float(Float),
+ parser_get_term_context(!.PS, Context, TermContext),
+ BaseTerm = functor(float(Float), [], TermContext),
+ BaseTermParse = ok(BaseTerm)
+ ;
+ Token = string(String),
+ parser_get_term_context(!.PS, Context, TermContext),
+ BaseTerm = functor(string(String), [], TermContext),
+ BaseTermParse = ok(BaseTerm)
+ ;
+ Token = implementation_defined(Name),
+ parser_get_term_context(!.PS, Context, TermContext),
+ BaseTerm = functor(implementation_defined(Name), [], TermContext),
+ BaseTermParse = ok(BaseTerm)
+ ;
+ ( Token = open
+ ; Token = open_ct
+ ),
+ parse_term(SubTermParse, !TokensLeft, !PS),
+ (
+ SubTermParse = ok(_),
+ ( if !.TokensLeft = token_cons(close, _Context, !:TokensLeft) then
+ BaseTermParse = SubTermParse
+ else
+ parser_unexpected("expecting `)' or operator", BaseTermParse,
+ !TokensLeft, !.PS)
+ )
+ ;
+ % Propagate error upwards.
+ SubTermParse = error(_, _),
+ BaseTermParse = SubTermParse
+ )
+ ;
+ Token = open_list,
+ parser_get_term_context(!.PS, Context, TermContext),
+ ( if !.TokensLeft = token_cons(close_list, _Context, !:TokensLeft) then
+ parse_special_atom("[]", TermContext, BaseTermParse,
+ !TokensLeft, !PS)
+ else
+ parse_list(BaseTermParse, !TokensLeft, !PS)
+ )
+ ;
+ Token = open_curly,
+ parser_get_term_context(!.PS, Context, TermContext),
+ ( if
+ !.TokensLeft = token_cons(close_curly, _Context, !:TokensLeft)
+ then
+ parse_special_atom("{}", TermContext, BaseTermParse,
+ !TokensLeft, !PS)
+ else
+ % This is a slight departure from ISO Prolog syntax -- instead of
+ % parsing "{1,2,3}" as "'{}'(','(1, ','(2, 3)))", we parse it as
+ % "'{}'(1,2,3)". This makes the structure of tuple functors
+ % the same as other functors.
+ parse_term(SubTermParse, !TokensLeft, !PS),
+ (
+ SubTermParse = ok(SubTerm),
+ conjunction_to_list(SubTerm, ArgTerms),
+ ( if
+ !.TokensLeft = token_cons(close_curly, _Context,
+ !:TokensLeft)
+ then
+ BaseTerm = functor(atom("{}"), ArgTerms, TermContext),
+ BaseTermParse = ok(BaseTerm)
+ else
+ parser_unexpected("expecting `}' or operator",
+ BaseTermParse, !TokensLeft, !.PS)
+ )
+ ;
+ SubTermParse = error(_, _),
+ % Propagate error upwards.
+ BaseTermParse = SubTermParse
+ )
+ )
+ ;
+ ( Token = close
+ ; Token = close_list
+ ; Token = close_curly
+ ; Token = ht_sep
+ ; Token = comma
+ ; Token = end
+ ; Token = junk(_)
+ ; Token = error(_)
+ ; Token = io_error(_)
+ ; Token = eof
+ ; Token = integer_dot(_)
+ ),
+ parser_unexpected_tok(Token, Context,
+ "unexpected token at start of (sub)term", BaseTermParse,
+ !TokensLeft, !.PS)
+ ),
+ ( if
+ BaseTermParse = ok(BaseTermOpen),
+ !.TokensLeft = token_cons(open_ct, _OpenContext, !:TokensLeft)
+ then
+ parse_higher_order_term_rest(BaseTermOpen, Context, TermParse,
+ !TokensLeft, !PS)
+ else
+ TermParse = BaseTermParse
+ ).
+
+ % As an extension to ISO Prolog syntax, we check for the syntax
+ % "Term(Args)", and parse it as the term ''(Term, Args). The aim
+ % of this extension is to provide a nicer syntax for higher-order stuff.
+ %
+ % Our caller should call us after it has seen "Term("; we parse
+ % the remainder, "Args)".
+ %
+ % The recursive call allows us to parse "Term(Args1)(Args2)" as well.
+ %
+:- pred parse_higher_order_term_rest(term(T)::in, token_context::in,
+ parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_higher_order_term_rest(BaseTerm, Context, TermParse, !TokensLeft, !PS) :-
+ parser_get_term_context(!.PS, Context, TermContext),
+ parse_args(ArgsParse, !TokensLeft, !PS),
+ (
+ ArgsParse = ok(Args),
+ ApplyTerm = functor(atom(""), [BaseTerm | Args], TermContext),
+ ( if
+ !.TokensLeft = token_cons(open_ct, _OpenContext, !:TokensLeft)
+ then
+ parse_higher_order_term_rest(ApplyTerm, Context, TermParse,
+ !TokensLeft, !PS)
+ else
+ TermParse = ok(ApplyTerm)
+ )
+ ;
+ ArgsParse = error(Message, Tokens),
+ % Propagate error upwards, after changing type.
+ TermParse = error(Message, Tokens)
+ ).
+
+:- pred conjunction_to_list(term(T)::in, list(term(T))::out) is det.
+
+conjunction_to_list(Term, ArgTerms) :-
+ ( if Term = old_term.functor(old_term.atom(","), [LeftTerm, RightTerm], _) then
+ conjunction_to_list(RightTerm, ArgTerms0),
+ ArgTerms = [LeftTerm | ArgTerms0]
+ else
+ ArgTerms = [Term]
+ ).
+
+:- pred parse_special_atom(string::in, old_term.context::in,
+ parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_special_atom(Atom, TermContext, Term, !TokensLeft, !PS) :-
+ ( if !.TokensLeft = token_cons(open_ct, _Context, !:TokensLeft) then
+ parse_args(Args0, !TokensLeft, !PS),
+ (
+ Args0 = ok(Args),
+ Term = ok(old_term.functor(old_term.atom(Atom), Args, TermContext))
+ ;
+ % Propagate error upwards.
+ Args0 = error(Message, Tokens),
+ Term = error(Message, Tokens)
+ )
+ else
+ Term = ok(old_term.functor(old_term.atom(Atom), [], TermContext))
+ ).
+
+:- pred parse_list(parse(term(T))::out, token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_list(List, !TokensLeft, !PS) :-
+ parse_list_elem(Arg0, !TokensLeft, !PS),
+ (
+ Arg0 = ok(Arg),
+ parse_list_tail(Arg, List, !TokensLeft, !PS)
+ ;
+ Arg0 = error(_, _),
+ % Propagate error.
+ List = Arg0
+ ).
+
+:- pred parse_list_tail(term(T)::in, parse(term(T))::out,
+ token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_list_tail(Arg, List, !TokensLeft, !PS) :-
+ (
+ !.TokensLeft = token_cons(Token, Context, !:TokensLeft),
+ parser_get_term_context(!.PS, Context, TermContext),
+ ( if Token = comma then
+ parse_list(Tail0, !TokensLeft, !PS),
+ (
+ Tail0 = ok(Tail),
+ List = ok(old_term.functor(old_term.atom("[|]"), [Arg, Tail],
+ TermContext))
+ ;
+ Tail0 = error(_, _),
+ % Propagate error.
+ List = Tail0
+ )
+ else if Token = ht_sep then
+ parse_arg(Tail0, !TokensLeft, !PS),
+ (
+ Tail0 = ok(Tail),
+ ( if
+ !.TokensLeft = token_cons(close_list, _Context,
+ !:TokensLeft)
+ then
+ List = ok(old_term.functor(old_term.atom("[|]"), [Arg, Tail],
+ TermContext))
+ else
+ parser_unexpected("expecting ']' or operator", List,
+ !TokensLeft, !.PS)
+ )
+ ;
+ Tail0 = error(_, _),
+ % Propagate error.
+ List = Tail0
+ )
+ else if Token = close_list then
+ Tail = old_term.functor(old_term.atom("[]"), [], TermContext),
+ List = ok(old_term.functor(old_term.atom("[|]"), [Arg, Tail],
+ TermContext))
+ else
+ parser_unexpected_tok(Token, Context,
+ "expected comma, `|', `]', or operator",
+ List, !TokensLeft, !.PS)
+ )
+ ;
+ !.TokensLeft = token_nil,
+ % XXX The error message should state the line that the list started on.
+ List = error("unexpected end-of-file in list", !.TokensLeft)
+ ).
+
+:- pred parse_args(parse(list(term(T)))::out,
+ token_list::in, token_list::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det
+ <= op_table(Ops).
+
+parse_args(List, !TokensLeft, !PS) :-
+ parse_arg(Arg0, !TokensLeft, !PS),
+ (
+ Arg0 = ok(Arg),
+ (
+ !.TokensLeft = token_cons(Token, Context, !:TokensLeft),
+ ( if Token = comma then
+ parse_args(Tail0, !TokensLeft, !PS),
+ (
+ Tail0 = ok(Tail),
+ List = ok([Arg|Tail])
+ ;
+ Tail0 = error(_, _),
+ % Propagate error upwards.
+ List = Tail0
+ )
+ else if Token = close then
+ List = ok([Arg])
+ else
+ parser_unexpected_tok(Token, Context,
+ "expected `,', `)', or operator", List, !TokensLeft, !.PS)
+ )
+ ;
+ !.TokensLeft = token_nil,
+ List = error("unexpected end-of-file in argument list",
+ !.TokensLeft)
+ )
+ ;
+ Arg0 = error(Message, Tokens),
+ % Propagate error upwards.
+ List = error(Message, Tokens)
+ ).
+
+%---------------------------------------------------------------------------%
+
+ % We encountered an error. See if the next token was an infix or postfix
+ % operator. If so, it would normally form part of the term, so the error
+ % must have been an operator precedence error. Otherwise, it was some
+ % other sort of error, so issue the usual error message.
+ %
+:- pred parser_unexpected(string::in, parse(U)::out,
+ token_list::in, token_list::out, parser_state(Ops, T)::in) is det
+ <= op_table(Ops).
+
+parser_unexpected(UsualMessage, Error, !TokensLeft, PS) :-
+ (
+ !.TokensLeft = token_cons(Token, Context, !:TokensLeft),
+ parser_unexpected_tok(Token, Context, UsualMessage, Error,
+ !TokensLeft, PS)
+ ;
+ !.TokensLeft = token_nil,
+ Error = error(UsualMessage, !.TokensLeft)
+ ).
+
+:- pred parser_unexpected_tok(token::in, token_context::in, string::in,
+ parse(U)::out, token_list::in, token_list::out, parser_state(Ops, T)::in)
+ is det <= op_table(Ops).
+
+parser_unexpected_tok(Token, Context, UsualMessage, Error, !TokensLeft, PS) :-
+ % Push the token back, so that the error message points at *it*
+ % rather than at the following token.
+ !:TokensLeft = token_cons(Token, Context, !.TokensLeft),
+ ( if
+ ( Token = name(Op)
+ ; Token = comma, Op = ","
+ ),
+ OpTable = parser_state_get_ops_table(PS),
+ ( ops.lookup_infix_op(OpTable, Op, _, _, _)
+ ; ops.lookup_postfix_op(OpTable, Op, _, _)
+ )
+ then
+ Error = error("operator precedence error", !.TokensLeft)
+ else
+ Error = error(UsualMessage, !.TokensLeft)
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- pred find_first_prefix_op(op_info::in, list(op_info)::in,
+ ops.priority::out, ops.assoc::out) is semidet.
+
+find_first_prefix_op(OpInfo, OtherOpInfos, OpPriority, RightAssoc) :-
+ OpInfo = op_info(Class, Priority),
+ ( if Class = prefix(RightAssocPrime) then
+ OpPriority = Priority,
+ RightAssoc = RightAssocPrime
+ else
+ OtherOpInfos = [HeadOpInfo | TailOpInfos],
+ find_first_prefix_op(HeadOpInfo, TailOpInfos, OpPriority, RightAssoc)
+ ).
+
+:- pred find_first_binary_prefix_op(op_info::in, list(op_info)::in,
+ ops.priority::out, ops.assoc::out, ops.assoc::out) is semidet.
+
+find_first_binary_prefix_op(OpInfo, OtherOpInfos,
+ OpPriority, RightAssoc, RightRightAssoc) :-
+ OpInfo = op_info(Class, Priority),
+ ( if Class = binary_prefix(RightAssocPrime, RightRightAssocPrime) then
+ OpPriority = Priority,
+ RightAssoc = RightAssocPrime,
+ RightRightAssoc = RightRightAssocPrime
+ else
+ OtherOpInfos = [HeadOpInfo | TailOpInfos],
+ find_first_binary_prefix_op(HeadOpInfo, TailOpInfos,
+ OpPriority, RightAssoc, RightRightAssoc)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred check_priority(ops.assoc::in, int::in, int::in) is semidet.
+
+check_priority(y, MaxPriority, Priority) :-
+ Priority =< MaxPriority.
+check_priority(x, MaxPriority, Priority) :-
+ Priority < MaxPriority.
+
+:- pred parser_get_term_context(parser_state(Ops, T)::in, token_context::in,
+ old_term.context::out) is det.
+
+parser_get_term_context(ParserState, TokenContext, TermContext) :-
+ FileName = parser_state_get_stream_name(ParserState),
+ old_term.context_init(FileName, TokenContext, TermContext).
+
+%---------------------------------------------------------------------------%
+
+:- pred could_start_term(token::in, bool::out) is det.
+
+could_start_term(name(_), yes).
+could_start_term(variable(_), yes).
+could_start_term(integer(_), yes).
+could_start_term(big_integer(_, _), yes).
+could_start_term(float(_), yes).
+could_start_term(string(_), yes).
+could_start_term(implementation_defined(_), yes).
+could_start_term(open, yes).
+could_start_term(open_ct, yes).
+could_start_term(close, no).
+could_start_term(open_list, yes).
+could_start_term(close_list, no).
+could_start_term(open_curly, yes).
+could_start_term(close_curly, no).
+could_start_term(ht_sep, no).
+could_start_term(comma, no).
+could_start_term(end, no).
+could_start_term(junk(_), no).
+could_start_term(error(_), no).
+could_start_term(io_error(_), no).
+could_start_term(eof, no).
+could_start_term(integer_dot(_), no).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+%
+% The representation of the parser state apart from the remaining token list.
+%
+
+:- type parser_state(Ops, T) % <= op_table(Ops)
+ ---> parser_state(
+ % The name of the stream being parsed.
+ ps_stream_name :: string,
+
+ % The current set of operators.
+ ps_ops_table :: Ops,
+
+ % The names of the variables in the term being parsed.
+ ps_varset :: varset(T),
+
+ % A map from variable names to variables. We use it to decide
+ % whether we have seen a variable before, or whether we have
+ % to create it.
+ ps_var_names :: map(string, var(T))
+ ).
+
+:- pred init_parser_state(Ops::in, string::in, parser_state(Ops, T)::out)
+ is det <= op_table(Ops).
+
+init_parser_state(Ops, FileName, ParserState) :-
+ old_varset.init(VarSet),
+ map.init(Names),
+ ParserState = parser_state(FileName, Ops, VarSet, Names).
+
+:- pred final_parser_state(parser_state(Ops, T)::in, varset(T)::out) is det.
+
+final_parser_state(ParserState, VarSet) :-
+ VarSet = parser_state_get_varset(ParserState).
+
+%---------------------------------------------------------------------------%
+
+:- func parser_state_get_stream_name(parser_state(Ops, T)) = string.
+:- func parser_state_get_ops_table(parser_state(Ops, T)) = Ops.
+:- func parser_state_get_varset(parser_state(Ops, T)) = varset(T).
+:- func parser_state_get_var_names(parser_state(Ops, T)) = map(string, var(T)).
+
+:- pred parser_state_set_varset(varset(T)::in,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det.
+:- pred parser_state_set_var_names(map(string, var(T))::in,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det.
+
+% If you want profiling to tell you the frequencies of these operations,
+% change the inline pragmas to no_inline pragmas.
+
+:- pragma inline(parser_state_get_stream_name/1).
+:- pragma inline(parser_state_get_ops_table/1).
+:- pragma inline(parser_state_get_varset/1).
+:- pragma inline(parser_state_get_var_names/1).
+
+:- pragma inline(parser_state_set_varset/3).
+:- pragma inline(parser_state_set_var_names/3).
+
+parser_state_get_stream_name(ParserState) = X :-
+ X = ParserState ^ ps_stream_name.
+parser_state_get_ops_table(ParserState) = X :-
+ X = ParserState ^ ps_ops_table.
+parser_state_get_varset(ParserState) = X :-
+ X = ParserState ^ ps_varset.
+parser_state_get_var_names(ParserState) = X :-
+ X = ParserState ^ ps_var_names.
+
+parser_state_set_varset(X, !ParserState) :-
+ !ParserState ^ ps_varset := X.
+parser_state_set_var_names(X, !ParserState) :-
+ !ParserState ^ ps_var_names := X.
+
+:- pred add_var(string::in, var(T)::out,
+ parser_state(Ops, T)::in, parser_state(Ops, T)::out) is det.
+
+add_var(VarName, Var, !ParserState) :-
+ ( if VarName = "_" then
+ VarSet0 = parser_state_get_varset(!.ParserState),
+ old_varset.new_var(Var, VarSet0, VarSet),
+ parser_state_set_varset(VarSet, !ParserState)
+ else
+ Names0 = parser_state_get_var_names(!.ParserState),
+ ( if map.search(Names0, VarName, Var0) then
+ Var = Var0
+ else
+ VarSet0 = parser_state_get_varset(!.ParserState),
+ old_varset.new_named_var(VarName, Var, VarSet0, VarSet),
+ map.det_insert(VarName, Var, Names0, Names),
+ parser_state_set_varset(VarSet, !ParserState),
+ parser_state_set_var_names(Names, !ParserState)
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
diff --git a/extras/old_term_parser/old_term.m b/extras/old_term_parser/old_term.m
index e69de29..f46dd49 100644
--- a/extras/old_term_parser/old_term.m
+++ b/extras/old_term_parser/old_term.m
@@ -0,0 +1,1329 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+% Copyright (C) 1993-2000,2003-2009,2011-2012 The University of Melbourne.
+% Copyright (C) 2015 The Mercury team.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% File: old_term.m.
+% Main author: fjh.
+% Stability: medium.
+%
+% This file provides a type `term' used to represent Herbrand terms,
+% and various predicates to manipulate terms and substitutions.
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module old_term.
+:- interface.
+
+:- import_module enum.
+:- import_module integer.
+:- import_module list.
+:- import_module map.
+
+%---------------------------------------------------------------------------%
+%
+% The term type represents logic terms (Herbrand terms, in the terminology
+% of logic programming theory).
+%
+% The term type is polymorphic. The intention is to allow terms representing
+% different kinds of things to specify a different type parameter. Since
+% e.g. term(type_a) is a different type from e.g. term(type_b), this should
+% prevent terms of different kinds from being accidentally mixed up.
+%
+% For the predicates that operate on more than one term, such as unify_term,
+% all the terms must use variables from the same varset.
+% (You can use varset.merge_renaming to combine two different varsets.)
+%
+
+:- type term(T)
+ ---> functor(
+ const,
+ list(term(T)),
+ old_term.context
+ )
+ ; variable(
+ var(T),
+ old_term.context
+ ).
+
+:- type var(T).
+
+:- type const
+ ---> atom(string)
+ ; integer(int)
+ ; big_integer(integer_base, integer)
+ % An integer that is too big for `int'.
+ ; string(string)
+ ; float(float)
+ ; implementation_defined(string).
+
+:- type integer_base
+ ---> base_2
+ ; base_8
+ ; base_10
+ ; base_16.
+
+:- type generic
+ ---> generic.
+
+:- type term == term(generic).
+:- type var == var(generic).
+
+%---------------------------------------------------------------------------%
+%
+% These predicates manage the supply of variables.
+% NOTE_TO_IMPLEMENTORS We might want to give these predicates unique modes.
+%
+
+:- type var_supply(T).
+
+ % init_var_supply(VarSupply):
+ %
+ % Returns a fresh var_supply for producing fresh variables.
+ %
+:- func init_var_supply = var_supply(T).
+:- pred init_var_supply(var_supply(T)).
+:- mode init_var_supply(out) is det.
+:- mode init_var_supply(in) is semidet. % implied
+
+ % create_var(Var, !VarSupply):
+ %
+ % Create a fresh variable (var) and return the updated var_supply.
+ %
+:- pred create_var(var(T)::out, var_supply(T)::in, var_supply(T)::out) is det.
+
+%---------------------------------------------------------------------------%
+
+ % from_int/1 should only be applied to integers returned by to_int/1.
+ % NOTE_TO_IMPLEMENTORS This instance declaration is needed to allow
+ % NOTE_TO_IMPLEMENTORS sets of variables to be represented using
+ % NOTE_TO_IMPLEMENTORS sparse_bitset.m and the other bitset modules.
+:- instance enum(var(_)).
+
+ % var_id(Variable):
+ %
+ % Returns a unique number associated with this variable w.r.t.
+ % its originating var_supply.
+ %
+:- func var_to_int(var(T)) = int.
+:- pred var_to_int(var(T)::in, int::out) is det.
+
+ % var_id(Variable):
+ %
+ % Returns a unique number associated with this variable w.r.t.
+ % its originating var_supply.
+ %
+ % Obsolete; please use var_to_int instead.
+ %
+:- func var_id(var(T)) = int.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(var_id/1).
+
+%---------------------------------------------------------------------------%
+
+:- type renaming(T) == map(var(T), var(T)).
+:- type renaming == renaming(generic).
+
+:- type substitution(T) == map(var(T), term(T)).
+:- type substitution == substitution(generic).
+
+%---------------------------------------------------------------------------%
+%
+% Predicates to unify terms.
+%
+
+ % unify_term(TermA, TermB, !Subst):
+ %
+ % Unify (with occur check) two terms with respect to the current
+ % substitution, and update that substitution as necessary.
+ %
+:- pred unify_term(term(T)::in, term(T)::in,
+ substitution(T)::in, substitution(T)::out) is semidet.
+
+ % unify_term_list(TermsA, TermsB, !Subst):
+ %
+ % Unify (with occur check) two lists of terms with respect to the current
+ % substitution, and update that substitution as necessary.
+ % Fail if the lists are not of equal length.
+ %
+:- pred unify_term_list(list(term(T))::in, list(term(T))::in,
+ substitution(T)::in, substitution(T)::out) is semidet.
+
+ % unify_term_dont_bind(TermA, TermB, DontBindVars, !Subst):
+ %
+ % Do the same job as unify_term(TermA, TermB, !Subst), but fail
+ % if any of the variables in DontBindVars would become bound
+ % by the unification.
+ %
+:- pred unify_term_dont_bind(term(T)::in, term(T)::in,
+ list(var(T))::in, substitution(T)::in, substitution(T)::out) is semidet.
+
+ % unify_term_list_dont_bind(TermsA, TermsB, DontBindVars, !Subst):
+ %
+ % Do the same job as unify_term_list(TermsA, TermsB, !Subst), but fail
+ % if any of the variables in DontBindVars would become bound
+ % by the unification.
+ %
+:- pred unify_term_list_dont_bind(list(term(T))::in, list(term(T))::in,
+ list(var(T))::in, substitution(T)::in, substitution(T)::out) is semidet.
+
+%---------------------------------------------------------------------------%
+%
+% Predicates to test subsumption.
+%
+
+ % list_subsumes(TermsA, TermsB, Subst):
+ %
+ % Succeeds iff the list TermsA subsumes (is more general than) TermsB,
+ % producing a substitution which, when applied to TermsA, will give TermsB.
+ %
+:- pred list_subsumes(list(term(T))::in, list(term(T))::in,
+ substitution(T)::out) is semidet.
+
+%---------------------------------------------------------------------------%
+%
+% Predicates that list the variables in terms.
+%
+
+ % vars(Term, Vars):
+ %
+ % Vars is the list of variables contained in Term, in the order
+ % obtained by traversing the term depth first, left-to-right.
+ %
+:- func vars(term(T)) = list(var(T)).
+:- pred vars(term(T)::in, list(var(T))::out) is det.
+
+ % As above, but with an accumulator.
+ %
+:- func vars_2(term(T), list(var(T))) = list(var(T)).
+:- pred vars_2(term(T)::in, list(var(T))::in, list(var(T))::out) is det.
+
+ % vars_list(TermList, Vars):
+ %
+ % Vars is the list of variables contained in TermList, in the order
+ % obtained by traversing the list of terms depth-first, left-to-right.
+ %
+:- func vars_list(list(term(T))) = list(var(T)).
+:- pred vars_list(list(term(T))::in, list(var(T))::out) is det.
+
+ % contains_var(Term, Var):
+ %
+ % True if Term contains Var. On backtracking returns all the variables
+ % contained in Term.
+ %
+:- pred contains_var(term(T), var(T)).
+:- mode contains_var(in, in) is semidet.
+:- mode contains_var(in, out) is nondet.
+
+ % contains_var_list(TermList, Var):
+ %
+ % True if TermList contains Var. On backtracking returns all the variables
+ % contained in Term.
+ %
+:- pred contains_var_list(list(term(T)), var(T)).
+:- mode contains_var_list(in, in) is semidet.
+:- mode contains_var_list(in, out) is nondet.
+
+%---------------------------------------------------------------------------%
+%
+% Predicates that look for variables in terms, possibly after a substitution.
+%
+
+ % occurs(Term, Var, Substitution):
+ %
+ % True iff Var occurs in the term resulting after applying Substitution
+ % to Term. Var must not be mapped by Substitution.
+ %
+:- pred occurs(term(T)::in, var(T)::in, substitution(T)::in) is semidet.
+
+ % As above, except for a list of terms rather than a single term.
+ %
+:- pred occurs_list(list(term(T))::in, var(T)::in, substitution(T)::in)
+ is semidet.
+
+ % is_ground(Term) is true iff Term contains no variables.
+ %
+:- pred is_ground(term(T)::in) is semidet.
+
+ % is_ground_in_bindings(Term, Bindings) is true iff all variables contained
+ % in Term are mapped to ground terms by Bindings.
+ %
+:- pred is_ground_in_bindings(term(T)::in, substitution(T)::in) is semidet.
+
+%---------------------------------------------------------------------------%
+%
+% Rename predicates that specify the substitution by giving the
+% variable/variable pair or pairs directly.
+%
+
+ % relabel_variable(Term0, Var, ReplacementVar, Term):
+ %
+ % Replace all occurrences of Var in Term0 with ReplacementVar and return
+ % the result as Term.
+ %
+ % Obsolete; please use rename_var_in_term instead.
+ %
+:- func relabel_variable(term(T), var(T), var(T)) = term(T).
+:- pred relabel_variable(term(T)::in, var(T)::in, var(T)::in, term(T)::out)
+ is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(relabel_variable/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(relabel_variable/4).
+
+ % relabel_variables(Terms0, Var, ReplacementVar, Terms):
+ %
+ % Replace all occurrences of Var in Terms0 with ReplacementVar and return
+ % the result as Terms.
+ %
+ % Obsolete; please use rename_var_in_terms instead.
+ %
+:- func relabel_variables(list(term(T)), var(T), var(T)) = list(term(T)).
+:- pred relabel_variables(list(term(T))::in, var(T)::in, var(T)::in,
+ list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(relabel_variables/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(relabel_variables/4).
+
+%---------------------%
+
+ % rename(Term0, Var, ReplacementVar, Term):
+ %
+ % Replace all occurrences of Var in Term0 with ReplacementVar,
+ % and return the result in Term.
+ %
+ % Obsolete; please use rename_var_in_term instead.
+ %
+:- func rename(term(T), var(T), var(T)) = term(T).
+:- pred rename(term(T)::in, var(T)::in, var(T)::in, term(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(rename/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(rename/4).
+
+ % rename_list(Terms0, Var, ReplacementVar, Terms):
+ %
+ % Replace all occurrences of Var in Terms0 with ReplacementVar,
+ % and return the result in Terms.
+ %
+ % Obsolete; please use rename_var_in_terms instead.
+ %
+:- func rename_list(list(term(T)), var(T), var(T)) = list(term(T)).
+:- pred rename_list(list(term(T))::in, var(T)::in, var(T)::in,
+ list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(rename_list/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(rename_list/4).
+
+%---------------------%
+
+ % rename_var_in_term(Var, ReplacementVar, Term0, Term):
+ %
+ % Replace all occurrences of Var in Term0 with ReplacementVar,
+ % and return the result in Term.
+ %
+:- pred rename_var_in_term(var(T)::in, var(T)::in,
+ term(T)::in, term(T)::out) is det.
+
+ % rename_var_in_terms(Var, ReplacementVar, Terms0, Terms):
+ %
+ % Replace all occurrences of Var in Terms0 with ReplacementVar,
+ % and return the result in Terms.
+ %
+:- pred rename_var_in_terms(var(T)::in, var(T)::in,
+ list(term(T))::in, list(term(T))::out) is det.
+
+%---------------------------------------------------------------------------%
+%
+% Rename predicates that specify the rename by giving an explicit
+% variable to variable map.
+%
+
+ % apply_renaming(Term0, Renaming, Term):
+ %
+ % Apply renaming to Term0 and return the result in Term.
+ %
+ % Obsolete; please use apply_renaming_in_term instead.
+ %
+:- func apply_renaming(term(T), renaming(T)) = term(T).
+:- pred apply_renaming(term(T)::in, renaming(T)::in, term(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_renaming/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_renaming/3).
+
+ % As above, except applies to a list of terms rather than a single term.
+ %
+ % Obsolete; please use apply_renaming_in_terms instead.
+ %
+:- func apply_renaming_to_list(list(term(T)), renaming(T)) = list(term(T)).
+:- pred apply_renaming_to_list(list(term(T))::in, renaming(T)::in,
+ list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_renaming_to_list/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_renaming_to_list/3).
+
+%---------------------%
+
+ % Applies apply_variable_renaming to a var.
+ %
+ % Obsolete; please use apply_renaming_in_var instead.
+ %
+:- func apply_variable_renaming_to_var(renaming(T), var(T)) = var(T).
+:- pred apply_variable_renaming_to_var(renaming(T)::in,
+ var(T)::in, var(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming_to_var/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming_to_var/3).
+
+ % Applies apply_variable_renaming to a list of vars.
+ %
+ % Obsolete; please use apply_renaming_in_vars instead.
+ %
+:- func apply_variable_renaming_to_vars(renaming(T),
+ list(var(T))) = list(var(T)).
+:- pred apply_variable_renaming_to_vars(renaming(T)::in,
+ list(var(T))::in, list(var(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming_to_vars/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming_to_vars/3).
+
+ % Same as relabel_variable, except relabels multiple variables.
+ % If a variable is not in the map, it is not replaced.
+ %
+ % Obsolete; please use apply_renaming_in_term instead.
+ %
+:- func apply_variable_renaming(term(T), renaming(T)) = term(T).
+:- pred apply_variable_renaming(term(T)::in, renaming(T)::in,
+ term(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming/3).
+
+ % Applies apply_variable_renaming to a list of terms.
+ %
+ % Obsolete; please use apply_renaming_in_terms instead.
+ %
+:- func apply_variable_renaming_to_list(list(term(T)), renaming(T)) =
+ list(term(T)).
+:- pred apply_variable_renaming_to_list(list(term(T))::in, renaming(T)::in,
+ list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming_to_list/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_variable_renaming_to_list/3).
+
+%---------------------%
+
+ % apply_renaming_in_var(Renaming, Var0, Var):
+ %
+ % Apply Renaming in Var0, and return the result as Var.
+ %
+:- pred apply_renaming_in_var(renaming(T)::in,
+ var(T)::in, var(T)::out) is det.
+
+ % apply_renaming_in_vars(Renaming, Vars0, Vars):
+ %
+ % Apply Renaming in Vars0, and return the result as Vars.
+ %
+:- pred apply_renaming_in_vars(renaming(T)::in,
+ list(var(T))::in, list(var(T))::out) is det.
+
+ % apply_renaming_in_term(Renaming, Term0, Term):
+ %
+ % Apply Renaming in Term0, and return the result as Term.
+ %
+:- pred apply_renaming_in_term(renaming(T)::in,
+ term(T)::in, term(T)::out) is det.
+
+ % apply_renaming_in_terms(Renaming, Terms0, Terms):
+ %
+ % Apply Renaming in Terms0, and return the result as Terms.
+ %
+:- pred apply_renaming_in_terms(renaming(T)::in,
+ list(term(T))::in, list(term(T))::out) is det.
+
+%---------------------------------------------------------------------------%
+%
+% Substitution predicates that specify the substitution by giving the
+% variable/term pair or pairs directly.
+%
+
+ % substitute(Term0, Var, ReplacementTerm, Term):
+ %
+ % Replace all occurrences of Var in Term0 with ReplacementTerm,
+ % and return the result as Term.
+ %
+ % Obsolete; please use substitute_var_in_term instead.
+ %
+:- func substitute(term(T), var(T), term(T)) = term(T).
+:- pred substitute(term(T)::in, var(T)::in, term(T)::in, term(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute/4).
+
+ % substitute_list(Var, ReplacementTerm, Terms0, Terms):
+ %
+ % Replace all occurrences of Var in Terms0 with ReplacementTerm,
+ % and return the result as Terms.
+ %
+ % Obsolete; please use substitute_var_in_terms instead.
+ %
+:- func substitute_list(list(term(T)), var(T), term(T)) = list(term(T)).
+:- pred substitute_list(list(term(T))::in, var(T)::in, term(T)::in,
+ list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute_list/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute_list/4).
+
+ % substitute_corresponding(Vars, ReplacementTerms, Term0, Term):
+ %
+ % Replace all occurrences of variables in Vars in Term0 with
+ % the corresponding term in ReplacementTerms, and return the result
+ % as Term. If Vars contains duplicates, or if Vars and ReplacementTerms
+ % have different lengths, the behaviour is undefined and probably harmful.
+ %
+ % Obsolete; please use substitute_corresponding_in_term instead.
+ %
+:- func substitute_corresponding(list(var(T)), list(term(T)),
+ term(T)) = term(T).
+:- pred substitute_corresponding(list(var(T))::in, list(term(T))::in,
+ term(T)::in, term(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute_corresponding/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute_corresponding/4).
+
+ % substitute_corresponding_list(Vars, ReplacementTerms, Terms0, Terms):
+ %
+ % Replace all occurrences of variables in Vars in Terms0 with
+ % the corresponding term in ReplacementTerms, and return the result
+ % as Terms. If Vars contains duplicates, or if Vars and ReplacementTerms
+ % have different lengths, the behaviour is undefined and probably harmful.
+ %
+ % Obsolete; please use substitute_corresponding_in_terms instead.
+ %
+:- func substitute_corresponding_list(list(var(T)), list(term(T)),
+ list(term(T))) = list(term(T)).
+:- pred substitute_corresponding_list(list(var(T))::in, list(term(T))::in,
+ list(term(T))::in, list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute_corresponding_list/3).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(substitute_corresponding_list/4).
+
+%---------------------%
+
+ % substitute_var_in_term(Var, ReplacementTerm, Term0, Term):
+ %
+ % Replace all occurrences of Var in Term0 with ReplacementTerm,
+ % and return the result in Term.
+ %
+:- pred substitute_var_in_term(var(T)::in, term(T)::in,
+ term(T)::in, term(T)::out) is det.
+
+ % substitute_var_in_terms(Var, ReplacementTerm, Terms0, Terms):
+ %
+ % Replace all occurrences of Var in Terms0 with ReplacementTerm,
+ % and return the result in Terms.
+ %
+:- pred substitute_var_in_terms(var(T)::in, term(T)::in,
+ list(term(T))::in, list(term(T))::out) is det.
+
+ % substitute_corresponding_in_term(Vars, ReplacementTerms, Term0, Term):
+ %
+ % Replace all occurrences of variables in Vars in Term0 with
+ % the corresponding term in ReplacementTerms, and return the result
+ % as Term. If Vars contains duplicates, or if Vars and ReplacementTerms
+ % have different lengths, the behaviour is undefined and probably harmful.
+ %
+:- pred substitute_corresponding_in_term(list(var(T))::in, list(term(T))::in,
+ term(T)::in, term(T)::out) is det.
+
+ % substitute_corresponding_in_terms(Vars, ReplacementTerms, Terms0, Terms):
+ %
+ % Replace all occurrences of variables in Vars in Terms0 with
+ % the corresponding term in ReplacementTerms, and return the result
+ % as Terms. If Vars contains duplicates, or if Vars and ReplacementTerms
+ % have different lengths, the behaviour is undefined and probably harmful.
+ %
+:- pred substitute_corresponding_in_terms(list(var(T))::in, list(term(T))::in,
+ list(term(T))::in, list(term(T))::out) is det.
+
+%---------------------------------------------------------------------------%
+%
+% Substitution predicates that specify the substitution by giving
+% an explicit variable to term map.
+%
+
+ % apply_substitution(Term0, Substitution, Term):
+ %
+ % Apply Substitution to Term0 and return the result as Term.
+ %
+ % Obsolete; please us apply_substitution_in_term instead.
+ %
+:- func apply_substitution(term(T), substitution(T)) = term(T).
+:- pred apply_substitution(term(T)::in, substitution(T)::in,
+ term(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_substitution/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_substitution/3).
+
+ % apply_substitution_to_list(Term0, Substitution, Term):
+ %
+ % Apply Substitution to Term0 and return the result as Term.
+ %
+ % Obsolete; please us apply_substitution_in_terms instead.
+ %
+:- func apply_substitution_to_list(list(term(T)), substitution(T)) =
+ list(term(T)).
+:- pred apply_substitution_to_list(list(term(T))::in, substitution(T)::in,
+ list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_substitution_to_list/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_substitution_to_list/3).
+
+ % apply_rec_substitution(Term0, Substitution, Term):
+ %
+ % Recursively apply Substitution to Term0 until no more substitutions
+ % can be applied, and then return the result as Term.
+ %
+ % Obsolete; please us apply_rec_substitution_in_term instead.
+ %
+:- func apply_rec_substitution(term(T), substitution(T)) = term(T).
+:- pred apply_rec_substitution(term(T)::in, substitution(T)::in,
+ term(T)::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_rec_substitution/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_rec_substitution/3).
+
+ % apply_rec_substitution_to_list(Terms0, Substitution, Terms):
+ %
+ % Recursively apply Substitution to Terms0 until no more substitutions
+ % can be applied, and then return the result as Terms.
+ %
+ % Obsolete; please us apply_rec_substitution_in_terms instead.
+ %
+:- func apply_rec_substitution_to_list(list(term(T)), substitution(T)) =
+ list(term(T)).
+:- pred apply_rec_substitution_to_list(list(term(T))::in, substitution(T)::in,
+ list(term(T))::out) is det.
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_rec_substitution_to_list/2).
+% NOTE_TO_IMPLEMENTORS :- pragma obsolete(apply_rec_substitution_to_list/3).
+
+%---------------------%
+
+ % apply_substitution_in_term(Substitution, Term0, Term):
+ %
+ % Apply Substitution to Term0 and return the result as Term.
+ %
+:- pred apply_substitution_in_term(substitution(T)::in,
+ term(T)::in, term(T)::out) is det.
+
+ % apply_substitution_in_terms(Substitution, Terms0, Terms):
+ %
+ % Apply Substitution to Terms0 and return the result as Terms.
+ %
+:- pred apply_substitution_in_terms(substitution(T)::in,
+ list(term(T))::in, list(term(T))::out) is det.
+
+ % apply_rec_substitution_in_term(Substitution, Term0, Term):
+ %
+ % Recursively apply Substitution to Term0 until no more substitutions
+ % can be applied, and then return the result as Term.
+ %
+:- pred apply_rec_substitution_in_term(substitution(T)::in,
+ term(T)::in, term(T)::out) is det.
+
+ % apply_rec_substitution_in_terms(Substitution, Terms0, Terms):
+ %
+ % Recursively apply Substitution to Terms0 until no more substitutions
+ % can be applied, and then return the result as Terms.
+ %
+:- pred apply_rec_substitution_in_terms(substitution(T)::in,
+ list(term(T))::in, list(term(T))::out) is det.
+
+%---------------------------------------------------------------------------%
+%
+% Conversions between variables and terms.
+%
+
+ % Convert a list of terms which are all vars into a list of vars.
+ % Abort (call error/1) if the list contains any non-variables.
+ %
+:- func term_list_to_var_list(list(term(T))) = list(var(T)).
+
+ % Convert a list of terms which are all vars into a list of vars.
+ %
+:- pred term_list_to_var_list(list(term(T))::in, list(var(T))::out) is semidet.
+
+ % Convert a list of terms which are all vars into a list of vars
+ % (or vice versa).
+ %
+:- func var_list_to_term_list(list(var(T))) = list(term(T)).
+:- pred var_list_to_term_list(list(var(T))::in, list(term(T))::out) is det.
+
+%---------------------------------------------------------------------------%
+
+ % generic_term(Term) is true iff `Term' is a term of type
+ % `term' ie `term(generic)'. It is useful because in some instances
+ % it doesn't matter what the type of a term is, and passing it to this
+ % predicate will ground the type avoiding unbound type variable warnings.
+ % NOTE_TO_IMPLEMENTORS XXX This is not all that useful,
+ % NOTE_TO_IMPLEMENTORS since we now have with_type.
+ %
+:- pred generic_term(term::in) is det.
+
+ % Coerce a term of type `T' into a term of type `U'.
+ %
+:- func coerce(term(T)) = term(U).
+:- pred coerce(term(T)::in, term(U)::out) is det.
+
+ % Coerce a var of type `T' into a var of type `U'.
+ %
+:- func coerce_var(var(T)) = var(U).
+:- pred coerce_var(var(T)::in, var(U)::out) is det.
+
+ % Coerce a var_supply of type `T' into a var_supply of type `U'.
+ %
+:- func coerce_var_supply(var_supply(T)) = var_supply(U).
+:- pred coerce_var_supply(var_supply(T)::in, var_supply(U)::out) is det.
+
+%---------------------------------------------------------------------------%
+
+ % NOTE_TO_IMPLEMENTORS: This type should get its own module.
+:- type old_term.context
+ ---> context(string, int).
+ % file name, line number.
+
+ % Return the context of a term.
+ %
+:- func get_term_context(term(T)) = old_term.context.
+
+ % Initialize the term context when reading in (or otherwise constructing)
+ % a term.
+ %
+:- func context_init = context.
+:- pred context_init(context::out) is det.
+:- func context_init(string, int) = context.
+:- pred context_init(string::in, int::in, context::out) is det.
+
+ % Given a term context, return the source line number.
+ %
+:- func context_line(context) = int.
+:- pred context_line(context::in, int::out) is det.
+
+ % Given a term context, return the source file.
+ %
+:- func context_file(context) = string.
+:- pred context_file(context::in, string::out) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+% Everything below here is not intended to be part of the public interface,
+% and will not be included in the Mercury library reference manual.
+:- interface.
+
+ % Returns the highest numbered variable returned from this var_supply.
+ %
+:- func var_supply_max_var(var_supply(T)) = var(T).
+
+:- func var_supply_num_allocated(var_supply(T)) = int.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module require.
+
+%---------------------------------------------------------------------------%
+
+:- type var(T)
+ ---> var(int).
+
+:- type var_supply(T)
+ ---> var_supply(int).
+
+%---------------------------------------------------------------------------%
+
+init_var_supply = var_supply(0).
+init_var_supply(var_supply(0)).
+
+create_var(var(V), var_supply(V0), var_supply(V)) :-
+ % We number variables using sequential integers.
+ V = V0 + 1.
+
+var_supply_max_var(var_supply(V)) = var(V).
+
+var_supply_num_allocated(var_supply(V)) = V.
+
+%---------------------------------------------------------------------------%
+
+:- instance enum(var(_)) where [
+ to_int(X) = old_term.var_to_int(X),
+ from_int(X) = old_term.unsafe_int_to_var(X)
+].
+
+ % Cast an integer to a var(T), subverting the type-checking.
+ %
+:- func unsafe_int_to_var(int) = var(T).
+
+unsafe_int_to_var(VarNum) = var(VarNum).
+
+var_to_int(var(VarNum)) = VarNum.
+var_to_int(var(VarNum), VarNum).
+
+var_id(var(VarNum)) = VarNum.
+
+%---------------------------------------------------------------------------%
+
+unify_term(TermX, TermY, !Subst) :-
+ (
+ TermX = variable(X, _),
+ TermY = variable(Y, _),
+ ( if map.search(!.Subst, X, TermBoundToX) then
+ ( if map.search(!.Subst, Y, TermBoundToY) then
+ % Both X and Y already have bindings, so just unify
+ % the terms they are bound to.
+ unify_term(TermBoundToX, TermBoundToY, !Subst)
+ else
+ % X is bound, but Y isn't.
+ apply_rec_substitution_in_term(!.Subst,
+ TermBoundToX, SubstTermBoundToX),
+ ( if SubstTermBoundToX = variable(Y, _) then
+ true
+ else
+ not occurs(SubstTermBoundToX, Y, !.Subst),
+ map.det_insert(Y, SubstTermBoundToX, !Subst)
+ )
+ )
+ else
+ ( if map.search(!.Subst, Y, TermBoundToY) then
+ % Y is bound, but X isn't.
+ apply_rec_substitution_in_term(!.Subst,
+ TermBoundToY, SubstTermBoundToY),
+ ( if SubstTermBoundToY = variable(X, _) then
+ true
+ else
+ not occurs(SubstTermBoundToY, X, !.Subst),
+ map.det_insert(X, SubstTermBoundToY, !Subst)
+ )
+ else
+ % Neither X nor Y are bound, so bind one to the other.
+ ( if X = Y then
+ true
+ else
+ map.det_insert(X, TermY, !Subst)
+ )
+ )
+ )
+ ;
+ TermX = variable(X, _),
+ TermY = functor(_, ArgTermsY, _),
+ ( if map.search(!.Subst, X, TermBoundToX) then
+ unify_term(TermBoundToX, TermY, !Subst)
+ else
+ not occurs_list(ArgTermsY, X, !.Subst),
+ map.det_insert(X, TermY, !Subst)
+ )
+ ;
+ TermX = functor(_, ArgTermsX, _),
+ TermY = variable(Y, _),
+ ( if map.search(!.Subst, Y, TermBoundToY) then
+ unify_term(TermX, TermBoundToY, !Subst)
+ else
+ not occurs_list(ArgTermsX, Y, !.Subst),
+ map.det_insert(Y, TermX, !Subst)
+ )
+ ;
+ TermX = functor(NameX, ArgTermsX, _),
+ TermY = functor(NameY, ArgTermsY, _),
+ NameX = NameY,
+ % ZZZ We could pretest whether the lengths of the argument lists match.
+ unify_term_list(ArgTermsX, ArgTermsY, !Subst)
+ ).
+
+unify_term_list([], [], !Subst).
+unify_term_list([TermX | TermXs], [TermY | TermYs], !Subst) :-
+ unify_term(TermX, TermY, !Subst),
+ unify_term_list(TermXs, TermYs, !Subst).
+
+%---------------------------------------------------------------------------%
+
+unify_term_dont_bind(TermX, TermY, DontBindVars, !Subst) :-
+ (
+ TermX = variable(X, _),
+ TermY = variable(Y, _),
+ ( if list.member(Y, DontBindVars) then
+ unify_term_bound_var(X, Y, DontBindVars, !Subst)
+ else if list.member(X, DontBindVars) then
+ unify_term_bound_var(Y, X, DontBindVars, !Subst)
+ else if map.search(!.Subst, X, TermBoundToX) then
+ ( if map.search(!.Subst, Y, TermBoundToY) then
+ % Both X and Y already have bindings, so just unify
+ % the terms they are bound to.
+ unify_term_dont_bind(TermBoundToX, TermBoundToY, DontBindVars,
+ !Subst)
+ else
+ % X is bound, but Y isn't.
+ apply_rec_substitution_in_term(!.Subst,
+ TermBoundToX, SubstTermBoundToX),
+ ( if SubstTermBoundToX = variable(Y, _) then
+ true
+ else
+ not occurs(SubstTermBoundToX, Y, !.Subst),
+ map.det_insert(Y, SubstTermBoundToX, !Subst)
+ )
+ )
+ else
+ ( if map.search(!.Subst, Y, TermBoundToY) then
+ % Y is bound, but X isn't.
+ apply_rec_substitution_in_term(!.Subst,
+ TermBoundToY, SubstTermBoundToY),
+ ( if SubstTermBoundToY = variable(X, _) then
+ true
+ else
+ not occurs(SubstTermBoundToY, X, !.Subst),
+ map.det_insert(X, SubstTermBoundToY, !Subst)
+ )
+ else
+ % Neither X nor Y are bound, so bind one to the other.
+ ( if X = Y then
+ true
+ else
+ map.det_insert(X, TermY, !Subst)
+ )
+ )
+ )
+ ;
+ TermX = variable(X, _),
+ TermY = functor(_, ArgTermsY, _),
+ ( if map.search(!.Subst, X, TermBoundToX) then
+ unify_term_dont_bind(TermBoundToX, TermY, DontBindVars, !Subst)
+ else
+ not occurs_list(ArgTermsY, X, !.Subst),
+ not list.member(X, DontBindVars),
+ map.det_insert(X, TermY, !Subst)
+ )
+ ;
+ TermX = functor(_, ArgTermsX, _),
+ TermY = variable(Y, _),
+ ( if map.search(!.Subst, Y, TermBoundToY) then
+ unify_term_dont_bind(TermX, TermBoundToY, DontBindVars, !Subst)
+ else
+ not occurs_list(ArgTermsX, Y, !.Subst),
+ not list.member(Y, DontBindVars),
+ map.det_insert(Y, TermX, !Subst)
+ )
+ ;
+ TermX = functor(NameX, ArgTermsX, _CX),
+ TermY = functor(NameY, ArgTermsY, _CY),
+ NameX = NameY,
+ list.length(ArgTermsX, ArityX),
+ list.length(ArgTermsY, ArityY),
+ ArityX = ArityY,
+ unify_term_list_dont_bind(ArgTermsX, ArgTermsY, DontBindVars, !Subst)
+ ).
+
+unify_term_list_dont_bind([], [], _, !Subst).
+unify_term_list_dont_bind([TermX | TermXs], [TermY | TermYs],
+ DontBindVars, !Subst) :-
+ unify_term_dont_bind(TermX, TermY, DontBindVars, !Subst),
+ unify_term_list_dont_bind(TermXs, TermYs, DontBindVars, !Subst).
+
+:- pred unify_term_bound_var(var(T)::in, var(T)::in, list(var(T))::in,
+ substitution(T)::in, substitution(T)::out) is semidet.
+
+unify_term_bound_var(X, BoundY, DontBindVars, !Subst) :-
+ ( if map.search(!.Subst, X, TermBoundToX) then
+ TermBoundToX = variable(NewX, _),
+ unify_term_bound_var(NewX, BoundY, DontBindVars, !Subst)
+ else
+ ( if X = BoundY then
+ true
+ else
+ not list.member(X, DontBindVars),
+ map.det_insert(X, variable(BoundY, context_init), !Subst)
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+
+list_subsumes(Terms1, Terms2, Subst) :-
+ % Terms1 subsumes Terms2 iff Terms1 can be unified with Terms2
+ % without binding any of the variables in Terms2.
+ vars_list(Terms2, Terms2Vars),
+ map.init(Subst0),
+ unify_term_list_dont_bind(Terms1, Terms2, Terms2Vars, Subst0, Subst).
+
+%---------------------------------------------------------------------------%
+
+vars(Term) = Vars :-
+ vars(Term, Vars).
+
+vars(Term, Vars) :-
+ vars_2(Term, [], Vars).
+
+vars_2(Term, Vars0) = Vars :-
+ vars_2(Term, Vars0, Vars).
+
+vars_2(Term, !Vars) :-
+ (
+ Term = variable(Var, _),
+ !:Vars = [Var | !.Vars]
+ ;
+ Term = functor(_, ArgTerms, _),
+ vars_2_list(ArgTerms, !Vars)
+ ).
+
+vars_list(Terms) = Vars :-
+ vars_list(Terms, Vars).
+
+vars_list(Terms, Vars) :-
+ vars_2_list(Terms, [], Vars).
+
+:- pred vars_2_list(list(term(T))::in, list(var(T))::in, list(var(T))::out)
+ is det.
+
+vars_2_list([], !Vars).
+vars_2_list([Term | Terms], !Vars) :-
+ vars_2_list(Terms, !Vars),
+ vars_2(Term, !Vars).
+
+%---------------------------------------------------------------------------%
+
+contains_var(variable(Var, _), Var).
+contains_var(functor(_, ArgTerms, _), Var) :-
+ contains_var_list(ArgTerms, Var).
+
+contains_var_list([Term | _], Var) :-
+ contains_var(Term, Var).
+contains_var_list([_ | Terms], Var) :-
+ contains_var_list(Terms, Var).
+
+%---------------------------------------------------------------------------%
+
+occurs(Term, Var, Subst) :-
+ (
+ Term = variable(X, _Context),
+ ( if X = Var then
+ true
+ else
+ map.search(Subst, X, TermBoundToX),
+ occurs(TermBoundToX, Var, Subst)
+ )
+ ;
+ Term = functor(_Name, ArgTerms, _Context),
+ occurs_list(ArgTerms, Var, Subst)
+ ).
+
+occurs_list([Term | Terms], Var, Subst) :-
+ ( if occurs(Term, Var, Subst) then
+ true
+ else
+ occurs_list(Terms, Var, Subst)
+ ).
+
+%---------------------------------------------------------------------------%
+
+is_ground(functor(_, ArgTerms, _)) :-
+ is_ground_list(ArgTerms).
+
+:- pred is_ground_list(list(term(T))::in) is semidet.
+
+is_ground_list([]).
+is_ground_list([Term | Terms]) :-
+ is_ground(Term),
+ is_ground_list(Terms).
+
+%---------------------------------------------------------------------------%
+
+is_ground_in_bindings(variable(V, _), Bindings) :-
+ map.search(Bindings, V, Binding),
+ is_ground_in_bindings(Binding, Bindings).
+is_ground_in_bindings(functor(_, Args, _), Bindings) :-
+ is_ground_in_bindings_list(Args, Bindings).
+
+:- pred is_ground_in_bindings_list(list(term(T))::in, substitution(T)::in)
+ is semidet.
+
+is_ground_in_bindings_list([], _Bindings).
+is_ground_in_bindings_list([Term | Terms], Bindings) :-
+ is_ground_in_bindings(Term, Bindings),
+ is_ground_in_bindings_list(Terms, Bindings).
+
+%---------------------------------------------------------------------------%
+
+% Forwarding functions and predicates, to be obsoleted.
+relabel_variable(Term0, Var, ReplacementVar) = Term :-
+ rename_var_in_term(Var, ReplacementVar, Term0, Term).
+relabel_variable(Term0, Var, ReplacementVar, Term) :-
+ rename_var_in_term(Var, ReplacementVar, Term0, Term).
+relabel_variables(Terms0, Var, ReplacementVar) = Terms :-
+ rename_var_in_terms(Var, ReplacementVar, Terms0, Terms).
+relabel_variables(Terms0, Var, ReplacementVar, Terms) :-
+ rename_var_in_terms(Var, ReplacementVar, Terms0, Terms).
+rename(Term0, Var, ReplacementVar) = Term :-
+ rename_var_in_term(Var, ReplacementVar, Term0, Term).
+rename(Term0, Var, ReplacementVar, Term) :-
+ rename_var_in_term(Var, ReplacementVar, Term0, Term).
+rename_list(Terms0, Var, ReplacementVar) = Terms :-
+ rename_var_in_terms(Var, ReplacementVar, Terms0, Terms).
+rename_list(Terms0, Var, ReplacementVar, Terms) :-
+ rename_var_in_terms(Var, ReplacementVar, Terms0, Terms).
+
+%---------------------%
+
+rename_var_in_term(Var, ReplacementVar, Term0, Term) :-
+ (
+ Term0 = variable(Var0, Context),
+ ( if Var0 = Var then
+ Term = variable(ReplacementVar, Context)
+ else
+ Term = Term0
+ )
+ ;
+ Term0 = functor(Name, ArgTerms0, Context),
+ rename_var_in_terms(Var, ReplacementVar, ArgTerms0, ArgTerms),
+ Term = functor(Name, ArgTerms, Context)
+ ).
+
+rename_var_in_terms(_Var, _ReplacementVar, [], []).
+rename_var_in_terms(Var, ReplacementVar, [Term0 | Terms0], [Term | Terms]) :-
+ rename_var_in_term(Var, ReplacementVar, Term0, Term),
+ rename_var_in_terms(Var, ReplacementVar, Terms0, Terms).
+
+%---------------------------------------------------------------------------%
+
+% Forwarding functions and predicates, to be obsoleted.
+apply_renaming(Term0, Renaming) = Term :-
+ apply_renaming_in_term(Renaming, Term0, Term).
+apply_renaming(Term0, Renaming, Term) :-
+ apply_renaming_in_term(Renaming, Term0, Term).
+apply_renaming_to_list(Terms0, Renaming) = Terms :-
+ apply_renaming_in_terms(Renaming, Terms0, Terms).
+apply_renaming_to_list(Terms0, Renaming, Terms) :-
+ apply_renaming_in_terms(Renaming, Terms0, Terms).
+apply_variable_renaming_to_var(Renaming, Var0) = Var :-
+ apply_renaming_in_var(Renaming, Var0, Var).
+apply_variable_renaming_to_var(Renaming, Var0, Var) :-
+ apply_renaming_in_var(Renaming, Var0, Var).
+apply_variable_renaming_to_vars(Renaming, Vars0) = Vars :-
+ apply_renaming_in_vars(Renaming, Vars0, Vars).
+apply_variable_renaming_to_vars(Renaming, Vars0, Vars) :-
+ apply_renaming_in_vars(Renaming, Vars0, Vars).
+apply_variable_renaming(Term0, Renaming) = Term :-
+ apply_renaming_in_term(Renaming, Term0, Term).
+apply_variable_renaming(Term0, Renaming, Term) :-
+ apply_renaming_in_term(Renaming, Term0, Term).
+apply_variable_renaming_to_list(Terms0, Renaming) = Terms :-
+ apply_renaming_in_terms(Renaming, Terms0, Terms).
+apply_variable_renaming_to_list(Terms0, Renaming, Terms) :-
+ apply_renaming_in_terms(Renaming, Terms0, Terms).
+
+%---------------------%
+
+apply_renaming_in_var(Renaming, Var0, Var) :-
+ ( if map.search(Renaming, Var0, NewVar) then
+ Var = NewVar
+ else
+ Var = Var0
+ ).
+
+apply_renaming_in_vars(_Renaming, [], []).
+apply_renaming_in_vars(Renaming, [Var0 | Vars0], [Var | Vars]) :-
+ apply_renaming_in_var(Renaming, Var0, Var),
+ apply_renaming_in_vars(Renaming, Vars0, Vars).
+
+apply_renaming_in_term(Renaming, Term0, Term) :-
+ (
+ Term0 = variable(Var0, Context),
+ apply_renaming_in_var(Renaming, Var0, Var),
+ Term = variable(Var, Context)
+ ;
+ Term0 = functor(Name, ArgTerms0, Context),
+ apply_renaming_in_terms(Renaming, ArgTerms0, ArgTerms),
+ Term = functor(Name, ArgTerms, Context)
+ ).
+
+apply_renaming_in_terms(_, [], []).
+apply_renaming_in_terms(Renaming, [Term0 | Terms0], [Term | Terms]) :-
+ apply_renaming_in_term(Renaming, Term0, Term),
+ apply_renaming_in_terms(Renaming, Terms0, Terms).
+
+%---------------------------------------------------------------------------%
+
+% Forwarding functions and predicates, to be obsoleted.
+substitute(Term0, Var, ReplacementTerm) = Term :-
+ substitute_var_in_term(Var, ReplacementTerm, Term0, Term).
+substitute(Term0, Var, ReplacementTerm, Term) :-
+ substitute_var_in_term(Var, ReplacementTerm, Term0, Term).
+substitute_list(Terms0, Var, ReplacementTerm) = Terms :-
+ substitute_var_in_terms(Var, ReplacementTerm, Terms0, Terms).
+substitute_list(Terms0, Var, ReplacementTerm, Terms) :-
+ substitute_var_in_terms(Var, ReplacementTerm, Terms0, Terms).
+substitute_corresponding(Vars, ReplacementTerms, Term0) = Term :-
+ substitute_corresponding_in_term(Vars, ReplacementTerms, Term0, Term).
+substitute_corresponding(Vars, ReplacementTerms, Term0, Term) :-
+ substitute_corresponding_in_term(Vars, ReplacementTerms, Term0, Term).
+substitute_corresponding_list(Vars, ReplacementTerms, Terms0) = Terms :-
+ substitute_corresponding_in_terms(Vars, ReplacementTerms, Terms0, Terms).
+substitute_corresponding_list(Vars, ReplacementTerms, Terms0, Terms) :-
+ substitute_corresponding_in_terms(Vars, ReplacementTerms, Terms0, Terms).
+
+%---------------------%
+
+substitute_var_in_term(Var, ReplacementTerm, Term0, Term) :-
+ (
+ Term0 = variable(Var0, _Context),
+ ( if Var0 = Var then
+ Term = ReplacementTerm
+ else
+ Term = Term0
+ )
+ ;
+ Term0 = functor(Name, ArgTerms0, Context),
+ substitute_var_in_terms(Var, ReplacementTerm, ArgTerms0, ArgTerms),
+ Term = functor(Name, ArgTerms, Context)
+ ).
+
+substitute_var_in_terms(_Var, _ReplacementTerm, [], []).
+substitute_var_in_terms(Var, ReplacementTerm,
+ [Term0 | Terms0], [Term | Terms]) :-
+ substitute_var_in_term(Var, ReplacementTerm, Term0, Term),
+ substitute_var_in_terms(Var, ReplacementTerm, Terms0, Terms).
+
+substitute_corresponding_in_term(Vars, ReplacementTerms, Term0, Term) :-
+ map.init(Subst0),
+ build_subst(Vars, ReplacementTerms, Subst0, Subst),
+ apply_substitution_in_term(Subst, Term0, Term).
+
+substitute_corresponding_in_terms(Vars, ReplacementTerms, Terms0, Terms) :-
+ map.init(Subst0),
+ build_subst(Vars, ReplacementTerms, Subst0, Subst),
+ apply_substitution_in_terms(Subst, Terms0, Terms).
+
+%---------------------%
+
+:- pred build_subst(list(var(T))::in, list(term(T))::in,
+ substitution(T)::in, substitution(T)::out) is det.
+
+build_subst([], [], !Subst).
+build_subst([], [_ | _], !Subst) :-
+ unexpected($module, $pred, "length mismatch").
+build_subst([_ | _], [], !Subst) :-
+ unexpected($module, $pred, "length mismatch").
+build_subst([Var | Vars], [Term | Terms], !Subst) :-
+ map.set(Var, Term, !Subst),
+ build_subst(Vars, Terms, !Subst).
+
+%---------------------------------------------------------------------------%
+
+% Forwarding functions and predicates, to be obsoleted.
+apply_substitution(Term0, Subst) = Term :-
+ apply_substitution_in_term(Subst, Term0, Term).
+apply_substitution(Term0, Subst, Term) :-
+ apply_substitution_in_term(Subst, Term0, Term).
+apply_substitution_to_list(Terms0, Subst) = Terms :-
+ apply_substitution_in_terms(Subst, Terms0, Terms).
+apply_substitution_to_list(Terms0, Subst, Terms) :-
+ apply_substitution_in_terms(Subst, Terms0, Terms).
+apply_rec_substitution(Term0, Subst) = Term :-
+ apply_rec_substitution_in_term(Subst, Term0, Term).
+apply_rec_substitution(Term0, Subst, Term) :-
+ apply_rec_substitution_in_term(Subst, Term0, Term).
+apply_rec_substitution_to_list(Terms0, Subst) = Terms :-
+ apply_rec_substitution_in_terms(Subst, Terms0, Terms).
+apply_rec_substitution_to_list(Terms0, Subst, Terms) :-
+ apply_rec_substitution_in_terms(Subst, Terms0, Terms).
+
+%---------------------%
+
+apply_substitution_in_term(Subst, Term0, Term) :-
+ (
+ Term0 = variable(Var, _),
+ ( if map.search(Subst, Var, ReplacementTerm) then
+ Term = ReplacementTerm
+ else
+ Term = Term0
+ )
+ ;
+ Term0 = functor(Name, ArgTerms0, Context),
+ apply_substitution_in_terms(Subst, ArgTerms0, ArgTerms),
+ Term = functor(Name, ArgTerms, Context)
+ ).
+
+apply_substitution_in_terms(_Subst, [], []).
+apply_substitution_in_terms(Subst, [Term0 | Terms0], [Term | Terms]) :-
+ apply_substitution_in_term(Subst, Term0, Term),
+ apply_substitution_in_terms(Subst, Terms0, Terms).
+
+apply_rec_substitution_in_term(Subst, Term0, Term) :-
+ (
+ Term0 = variable(Var, _),
+ ( if map.search(Subst, Var, ReplacementTerm) then
+ % Recursively apply the substitution to the replacement.
+ apply_rec_substitution_in_term(Subst, ReplacementTerm, Term)
+ else
+ Term = Term0
+ )
+ ;
+ Term0 = functor(Name, ArgTerms0, Context),
+ apply_rec_substitution_in_terms(Subst, ArgTerms0, ArgTerms),
+ Term = functor(Name, ArgTerms, Context)
+ ).
+
+apply_rec_substitution_in_terms(_Subst, [], []).
+apply_rec_substitution_in_terms(Subst, [Term0 | Terms0], [Term | Terms]) :-
+ apply_rec_substitution_in_term(Subst, Term0, Term),
+ apply_rec_substitution_in_terms(Subst, Terms0, Terms).
+
+%---------------------------------------------------------------------------%
+
+term_list_to_var_list(Terms) = Vars :-
+ ( if term_list_to_var_list(Terms, VarsPrime) then
+ Vars = VarsPrime
+ else
+ unexpected($module, $pred, "not all vars")
+ ).
+
+term_list_to_var_list([], []).
+term_list_to_var_list([variable(Var, _) | Terms], [Var | Vars]) :-
+ term_list_to_var_list(Terms, Vars).
+
+var_list_to_term_list(Vs) = Ts :-
+ var_list_to_term_list(Vs, Ts).
+
+var_list_to_term_list([], []).
+var_list_to_term_list([Var | Vars], [variable(Var, context_init) | Terms]) :-
+ var_list_to_term_list(Vars, Terms).
+
+%---------------------------------------------------------------------------%
+
+generic_term(_).
+
+coerce(TermTypeA) = TermTypeB :-
+ coerce(TermTypeA, TermTypeB).
+
+coerce(TermTypeA, TermTypeB) :-
+ % Normally calls to this predicate should only be generated by the
+ % compiler, but type coercion by copying was taking about 3% of the
+ % compiler's runtime.
+ private_builtin.unsafe_type_cast(TermTypeA, TermTypeB).
+
+coerce_var(VarTypeA) = VarTypeB :-
+ coerce_var(VarTypeA, VarTypeB).
+
+coerce_var(var(VarNum), var(VarNum)).
+
+coerce_var_supply(VarSupplyTypeA) = VarSupplyTypeB :-
+ coerce_var_supply(VarSupplyTypeA, VarSupplyTypeB).
+
+coerce_var_supply(var_supply(Supply), var_supply(Supply)).
+
+%---------------------------------------------------------------------------%
+
+get_term_context(Term) = Context :-
+ ( Term = functor(_, _, Context)
+ ; Term = variable(_, Context)
+ ).
+
+context_line(context(_, LineNumber)) = LineNumber.
+context_line(context(_, LineNumber), LineNumber).
+
+context_file(context(FileName, _)) = FileName.
+context_file(context(FileName, _), FileName).
+
+context_init = context("", 0).
+context_init(context("", 0)).
+
+context_init(File, LineNumber) = context(File, LineNumber).
+context_init(File, LineNumber, context(File, LineNumber)).
+
+%---------------------------------------------------------------------------%
+
diff --git a/extras/old_term_parser/old_term_io.m b/extras/old_term_parser/old_term_io.m
index e69de29..f52a57f 100644
--- a/extras/old_term_parser/old_term_io.m
+++ b/extras/old_term_parser/old_term_io.m
@@ -0,0 +1,962 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+% Copyright (C) 1994-2006, 2009, 2011-2012 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% File: old_term_io.m.
+% Main author: fjh.
+% Stability: medium to high.
+%
+% This file encapsulates all the term I/O.
+% This exports predicates to read and write terms in the
+% nice ground representation provided in term.m.
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module old_term_io.
+:- interface.
+
+:- import_module char.
+:- import_module io.
+:- import_module ops.
+:- import_module stream.
+:- import_module old_term.
+:- import_module old_varset.
+
+%---------------------------------------------------------------------------%
+
+:- type read_term(T)
+ ---> eof
+ ; error(string, int)
+ ; term(varset(T), term(T)).
+
+:- type read_term == read_term(generic).
+
+ % Read a term from the current input stream or from the given input stream.
+ %
+ % Similar to NU-Prolog read_term/2, except that resulting term
+ % is in the ground representation.
+ %
+ % Binds Result to either `eof', `term(VarSet, Term)', or
+ % `error(Message, LineNumber)'.
+ %
+:- pred read_term(read_term(T)::out, io::di, io::uo) is det.
+:- pred read_term(io.text_input_stream::in, read_term(T)::out,
+ io::di, io::uo) is det.
+
+ % As above, except uses the given operator table instead of
+ % the standard Mercury operators.
+ %
+:- pred read_term_with_op_table(Ops::in,
+ read_term(T)::out, io::di, io::uo) is det <= op_table(Ops).
+:- pred read_term_with_op_table(io.text_input_stream::in, Ops::in,
+ read_term(T)::out, io::di, io::uo) is det <= op_table(Ops).
+
+ % Writes a term to the current output stream or to the specified output
+ % stream. Uses the variable names specified by the varset.
+ % Writes _N for all unnamed variables, with N starting at 0.
+ %
+:- pred write_term(varset(T)::in, term(T)::in, io::di, io::uo) is det.
+:- pred write_term(io.output_stream::in, varset(T)::in, term(T)::in,
+ io::di, io::uo) is det.
+
+ % As above, except uses the given operator table instead of the
+ % standard Mercury operators.
+ %
+:- pred write_term_with_op_table(Ops::in,
+ varset(T)::in, term(T)::in, io::di, io::uo) is det <= op_table(Ops).
+:- pred write_term_with_op_table(io.text_output_stream::in, Ops::in,
+ varset(T)::in, term(T)::in, io::di, io::uo) is det <= op_table(Ops).
+
+ % As above, except it appends a period and new-line.
+ %
+:- pred write_term_nl(varset(T)::in, term(T)::in, io::di, io::uo) is det.
+:- pred write_term_nl(io.text_output_stream::in, varset(T)::in, term(T)::in,
+ io::di, io::uo) is det.
+
+ % As above, except it appends a period and new-line.
+ %
+:- pred write_term_nl_with_op_table(Ops::in,
+ varset(T)::in, term(T)::in, io::di, io::uo) is det <= op_table(Ops).
+:- pred write_term_nl_with_op_table(io.text_output_stream::in, Ops::in,
+ varset(T)::in, term(T)::in, io::di, io::uo) is det <= op_table(Ops).
+
+ % Writes a constant (integer, float, string, or atom) to
+ % the current output stream, or to the specified output stream.
+ %
+:- pred write_constant(const::in, io::di, io::uo) is det.
+:- pred write_constant(io.text_output_stream::in, const::in,
+ io::di, io::uo) is det.
+
+ % Like write_constant, but return the result in a string.
+ %
+:- func format_constant(const) = string.
+
+ % Writes a variable to the current output stream, or to the
+ % specified output stream.
+ %
+:- pred write_variable(var(T)::in, varset(T)::in, io::di, io::uo) is det.
+:- pred write_variable(io.text_output_stream::in, var(T)::in, varset(T)::in,
+ io::di, io::uo) is det.
+
+ % As above, except uses the given operator table instead of the
+ % standard Mercury operators.
+ %
+:- pred write_variable_with_op_table(Ops::in,
+ var(T)::in, varset(T)::in, io::di, io::uo) is det <= op_table(Ops).
+:- pred write_variable_with_op_table(io.text_output_stream::in, Ops::in,
+ var(T)::in, varset(T)::in, io::di, io::uo) is det <= op_table(Ops).
+
+ % Given a string S, write S in double-quotes, with characters
+ % escaped if necessary, to stdout.
+ %
+:- pred quote_string(string::in, io::di, io::uo) is det.
+
+:- pred quote_string(Stream::in, string::in, State::di, State::uo) is det
+ <= (stream.writer(Stream, string, State),
+ stream.writer(Stream, char, State)).
+
+ % Like quote_string, but return the result in a string.
+ %
+:- func quoted_string(string) = string.
+
+ % Given an atom-name A, write A, enclosed in single-quotes if necessary,
+ % with characters escaped if necessary, to stdout.
+ %
+:- pred quote_atom(string::in, io::di, io::uo) is det.
+
+:- pred quote_atom(Stream::in, string::in, State::di, State::uo) is det
+ <= (stream.writer(Stream, string, State),
+ stream.writer(Stream, char, State)).
+
+ % Like quote_atom, but return the result in a string.
+ %
+:- func quoted_atom(string) = string.
+
+ % Given a character C, write C in single-quotes,
+ % escaped if necessary, to stdout.
+ %
+:- pred quote_char(char::in, io::di, io::uo) is det.
+
+:- pred quote_char(Stream::in, char::in, State::di, State::uo) is det
+ <= (stream.writer(Stream, string, State),
+ stream.writer(Stream, char, State)).
+
+ % Like quote_char, but return the result in a string.
+ %
+:- func quoted_char(char) = string.
+
+ % Given a character C, write C, escaped if necessary, to stdout.
+ % The character is not enclosed in quotes.
+ %
+:- pred write_escaped_char(char::in, io::di, io::uo) is det.
+
+:- pred write_escaped_char(Stream::in, char::in, State::di, State::uo) is det
+ <= (stream.writer(Stream, string, State),
+ stream.writer(Stream, char, State)).
+
+ % Like write_escaped_char, but return the result in a string.
+ %
+:- func escaped_char(char) = string.
+
+ % A reversible version of escaped_char.
+ %
+:- pred string_is_escaped_char(char, string).
+:- mode string_is_escaped_char(in, out) is det.
+:- mode string_is_escaped_char(out, in) is semidet.
+
+ % Given a string S, write S, with characters escaped if necessary,
+ % to stdout. The string is not enclosed in quotes.
+ %
+:- pred write_escaped_string(string::in, io::di, io::uo) is det.
+
+:- pred write_escaped_string(Stream::in, string::in,
+ State::di, State::uo) is det
+ <= (stream.writer(Stream, string, State),
+ stream.writer(Stream, char, State)).
+
+ % Like write_escaped_char, but return the result in a string.
+ %
+:- func escaped_string(string) = string.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+% Everything below here is not intended to be part of the public interface,
+% and will not be included in the Mercury library reference manual.
+
+%---------------------------------------------------------------------------%
+
+:- interface.
+
+ % Convert `integer_base' constant to its numeric value.
+ %
+:- func integer_base_int(integer_base) = int.
+
+ % Return the prefix for integer literals of the given base.
+ %
+:- func integer_base_prefix(integer_base) = string.
+
+ % Convert a character to the corresponding octal escape code.
+ %
+ % We use ISO-Prolog style octal escapes, which are of the form '\nnn\';
+ % note that unlike C octal escapes, they are terminated with a backslash.
+ %
+ % XXX Using this predicate in the compiler may cause problems interfacing
+ % with versions of the compiler that have been built in grades which use
+ % different character representations.
+ %
+:- func mercury_escape_char(char) = string.
+
+ % Succeed if the given character is a Mercury punctuation character.
+ %
+:- pred is_mercury_punctuation_char(char::in) is semidet.
+
+ % encode_escaped_char(Char, Str):
+ %
+ % Succeed in one of two cases:
+ %
+ % - Char is 'x', and Str is "x", where x is a valid Mercury source
+ % character, or
+ % - Char is '\x' and Str is "\x", where '\x' is a valid character
+ % escape sequence.
+ %
+:- pred encode_escaped_char(char, string).
+:- mode encode_escaped_char(in, out) is semidet.
+:- mode encode_escaped_char(out, in) is semidet.
+
+ % for use by io.m.
+
+:- type adjacent_to_graphic_token
+ ---> maybe_adjacent_to_graphic_token
+ ; not_adjacent_to_graphic_token.
+
+:- pred quote_atom_agt(string::in, adjacent_to_graphic_token::in,
+ io::di, io::uo) is det.
+
+:- pred quote_atom_agt(Stream::in, string::in,
+ adjacent_to_graphic_token::in, State::di, State::uo) is det
+ <= (stream.writer(Stream, string, State),
+ stream.writer(Stream, char, State)).
+
+:- func quoted_atom_agt(string, adjacent_to_graphic_token) = string.
+
+:- pragma type_spec(old_term_io.quote_string/4,
+ (Stream = io.output_stream, State = io.state)).
+:- pragma type_spec(old_term_io.quote_atom/4,
+ (Stream = io.output_stream, State = io.state)).
+:- pragma type_spec(old_term_io.write_escaped_string/4,
+ (Stream = io.output_stream, State = io.state)).
+:- pragma type_spec(old_term_io.write_escaped_char/4,
+ (Stream = io.output_stream, State = io.state)).
+:- pragma type_spec(old_term_io.quote_char/4,
+ (Stream = io.output_stream, State = io.state)).
+:- pragma type_spec(old_term_io.quote_atom_agt/5,
+ (Stream = io.output_stream, State = io.state)).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module bool.
+:- import_module int.
+:- import_module integer.
+:- import_module old_lexer.
+:- import_module list.
+:- import_module old_parser.
+:- import_module string.
+:- import_module stream.string_writer.
+
+%---------------------------------------------------------------------------%
+
+read_term(Result, !IO) :-
+ io.input_stream(InStream, !IO),
+ old_term_io.read_term(InStream, Result, !IO).
+
+read_term(InStream, Result, !IO) :-
+ io.get_op_table(Ops, !IO),
+ old_term_io.read_term_with_op_table(InStream, Ops, Result, !IO).
+
+read_term_with_op_table(Ops, Result, !IO) :-
+ io.input_stream(InStream, !IO),
+ old_term_io.read_term_with_op_table(InStream, Ops, Result, !IO).
+
+read_term_with_op_table(InStream, Ops, Result, !IO) :-
+ old_parser.read_term_with_op_table(InStream, Ops, Result, !IO).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+%
+% Write a variable.
+%
+% There are two ways we could choose to write unnamed variables.
+%
+% 1 Convert the variable to an integer representation and write
+% `_N' where N is that integer representation. This has the
+% advantage that such variables get printed in a canonical
+% way, so rearranging terms containing such variables will
+% not effect the way they are numbered (this includes breaking
+% up a term and printing the pieces separately).
+%
+% 2 Number the unnamed variables from 0 and write `_N' where
+% N is the number in the sequence of such variables. This has
+% the advantage that such variables can be visually scanned
+% rather more easily (for example in error messages).
+%
+% An ideal solution would be to provide both, and a flag to choose
+% between the two. At the moment we provide only the first, though
+% the infrastructure for the second is present in the code.
+%
+
+write_variable(Variable, VarSet, !IO) :-
+ io.output_stream(OutStream, !IO),
+ write_variable(OutStream, Variable, VarSet, !IO).
+
+write_variable(OutStream, Variable, VarSet, !IO) :-
+ io.get_op_table(Ops, !IO),
+ old_term_io.write_variable_with_op_table(OutStream, Ops, Variable, VarSet,
+ !IO).
+
+write_variable_with_op_table(Ops, Variable, VarSet, !IO) :-
+ io.output_stream(OutStream, !IO),
+ write_variable_with_op_table(OutStream, Ops, Variable, VarSet, !IO).
+
+write_variable_with_op_table(OutStream, Ops, Variable, VarSet, !IO) :-
+ old_term_io.write_variable_2(OutStream, Ops, Variable, VarSet, _, 0, _, !IO).
+
+:- pred old_term_io.write_variable_2(io.text_output_stream::in, Ops::in,
+ var(T)::in, varset(T)::in, varset(T)::out, int::in, int::out,
+ io::di, io::uo) is det <= op_table(Ops).
+
+write_variable_2(OutStream, Ops, Id, !VarSet, !N, !IO) :-
+ ( if old_varset.search_var(!.VarSet, Id, Val) then
+ old_term_io.write_term_2(OutStream, Ops, Val, !VarSet, !N, !IO)
+ else if old_varset.search_name(!.VarSet, Id, Name) then
+ io.write_string(OutStream, Name, !IO)
+ else
+ % XXX The names we generate here *could* clash with the name
+ % of an explicit-named variable.
+ old_term.var_to_int(Id, VarNum),
+ string.int_to_string(VarNum, Num),
+ string.append("_", Num, VarName),
+ old_varset.name_var(Id, VarName, !VarSet),
+ !:N = !.N + 1,
+ io.write_string(OutStream, VarName, !IO)
+ ).
+
+%---------------------------------------------------------------------------%
+
+write_term(VarSet, Term, !IO) :-
+ io.output_stream(OutStream, !IO),
+ write_term(OutStream, VarSet, Term, !IO).
+
+write_term(OutStream, VarSet, Term, !IO) :-
+ io.get_op_table(Ops, !IO),
+ old_term_io.write_term_with_op_table(OutStream, Ops, VarSet, Term, !IO).
+
+write_term_with_op_table(Ops, VarSet, Term, !IO) :-
+ io.output_stream(OutStream, !IO),
+ write_term_with_op_table(OutStream, Ops, VarSet, Term, !IO).
+
+write_term_with_op_table(OutStream, Ops, VarSet, Term, !IO) :-
+ old_term_io.write_term_2(OutStream, Ops, Term, VarSet, _, 0, _, !IO).
+
+:- pred old_term_io.write_term_2(io.text_output_stream::in, Ops::in,
+ term(T)::in, varset(T)::in, varset(T)::out, int::in, int::out,
+ io::di, io::uo) is det <= op_table(Ops).
+
+write_term_2(OutStream, Ops, Term, !VarSet, !N, !IO) :-
+ old_term_io.write_term_3(OutStream, Ops, Term, ops.max_priority(Ops) + 1,
+ !VarSet, !N, !IO).
+
+:- pred old_term_io.write_arg_term(io.text_output_stream::in, Ops::in,
+ term(T)::in, varset(T)::in, varset(T)::out, int::in, int::out,
+ io::di, io::uo) is det <= op_table(Ops).
+
+write_arg_term(OutStream, Ops, Term, !VarSet, !N, !IO) :-
+ old_term_io.write_term_3(OutStream, Ops, Term, ops.arg_priority(Ops),
+ !VarSet, !N, !IO).
+
+:- pred old_term_io.write_term_3(io.text_output_stream::in, Ops::in,
+ term(T)::in, ops.priority::in, varset(T)::in, varset(T)::out,
+ int::in, int::out, io::di, io::uo) is det <= op_table(Ops).
+
+write_term_3(OutStream, Ops, old_term.variable(Id, _), _, !VarSet, !N, !IO) :-
+ old_term_io.write_variable_2(OutStream, Ops, Id, !VarSet, !N, !IO).
+write_term_3(OutStream, Ops, old_term.functor(Functor, Args, _), Priority,
+ !VarSet, !N, !IO) :-
+ ( if
+ Functor = old_term.atom("[|]"),
+ Args = [ListHead, ListTail]
+ then
+ io.write_char(OutStream, '[', !IO),
+ old_term_io.write_arg_term(OutStream, Ops, ListHead, !VarSet, !N, !IO),
+ old_term_io.write_list_tail(OutStream, Ops, ListTail, !VarSet, !N, !IO),
+ io.write_char(OutStream, ']', !IO)
+ else if
+ Functor = old_term.atom("[]"),
+ Args = []
+ then
+ io.write_string(OutStream, "[]", !IO)
+ else if
+ Functor = old_term.atom("{}"),
+ Args = [BracedTerm]
+ then
+ io.write_string(OutStream, "{ ", !IO),
+ old_term_io.write_term_2(OutStream, Ops, BracedTerm, !VarSet, !N, !IO),
+ io.write_string(OutStream, " }", !IO)
+ else if
+ Functor = old_term.atom("{}"),
+ Args = [BracedHead | BracedTail]
+ then
+ io.write_char(OutStream, '{', !IO),
+ old_term_io.write_arg_term(OutStream, Ops, BracedHead, !VarSet, !N, !IO),
+ old_term_io.write_term_args(OutStream, Ops, BracedTail, !VarSet, !N, !IO),
+ io.write_char(OutStream, '}', !IO)
+ else if
+ % The empty functor '' is used for higher-order syntax: Var(Arg, ...)
+ % gets parsed as ''(Var, Arg). When writing it out, we want to use
+ % the nice syntax.
+ Functor = old_term.atom(""),
+ Args = [old_term.variable(Var, _), FirstArg | OtherArgs]
+ then
+ old_term_io.write_variable_2(OutStream, Ops, Var, !VarSet, !N, !IO),
+ io.write_char(OutStream, '(', !IO),
+ old_term_io.write_arg_term(OutStream, Ops, FirstArg, !VarSet, !N, !IO),
+ old_term_io.write_term_args(OutStream, Ops, OtherArgs, !VarSet, !N, !IO),
+ io.write_char(OutStream, ')', !IO)
+ else if
+ Args = [PrefixArg],
+ Functor = old_term.atom(OpName),
+ ops.lookup_prefix_op(Ops, OpName, OpPriority, OpAssoc)
+ then
+ % ZZZ io.output_stream(Stream, !IO),
+ maybe_write_paren(OutStream, '(', Priority, OpPriority, !IO),
+ old_term_io.write_constant(OutStream, Functor, !IO),
+ io.write_char(OutStream, ' ', !IO),
+ adjust_priority_for_assoc(OpPriority, OpAssoc, NewPriority),
+ old_term_io.write_term_3(OutStream, Ops, PrefixArg, NewPriority,
+ !VarSet, !N, !IO),
+ maybe_write_paren(OutStream, ')', Priority, OpPriority, !IO)
+ else if
+ Args = [PostfixArg],
+ Functor = old_term.atom(OpName),
+ ops.lookup_postfix_op(Ops, OpName, OpPriority, OpAssoc)
+ then
+ % ZZZ io.output_stream(OutStream, !IO),
+ maybe_write_paren(OutStream, '(', Priority, OpPriority, !IO),
+ adjust_priority_for_assoc(OpPriority, OpAssoc, NewPriority),
+ old_term_io.write_term_3(OutStream, Ops, PostfixArg, NewPriority,
+ !VarSet, !N, !IO),
+ io.write_char(OutStream, ' ', !IO),
+ old_term_io.write_constant(OutStream, Functor, !IO),
+ maybe_write_paren(OutStream, ')', Priority, OpPriority, !IO)
+ else if
+ Args = [Arg1, Arg2],
+ Functor = old_term.atom(OpName),
+ ops.lookup_infix_op(Ops, OpName, OpPriority, LeftAssoc, RightAssoc)
+ then
+ % ZZZ io.output_stream(OutStream, !IO),
+ maybe_write_paren(OutStream, '(', Priority, OpPriority, !IO),
+ adjust_priority_for_assoc(OpPriority, LeftAssoc, LeftPriority),
+ old_term_io.write_term_3(OutStream, Ops, Arg1, LeftPriority,
+ !VarSet, !N, !IO),
+ ( if OpName = "," then
+ io.write_string(OutStream, ", ", !IO)
+ else if OpName = "." then
+ % If the operator is '.'/2, then we must not put spaces around it
+ % (or at the very least, we should not put spaces afterwards)
+ % because that would make it appear as the end-of-term token.
+ % However, we do have to quote it if the right hand side
+ % can begin with a digit.
+ ( if starts_with_digit(Arg2) then
+ Dot = "'.'"
+ else
+ Dot = "."
+ ),
+ io.write_string(OutStream, Dot, !IO)
+ else
+ io.write_char(OutStream, ' ', !IO),
+ old_term_io.write_constant(OutStream, Functor, !IO),
+ io.write_char(OutStream, ' ', !IO)
+ ),
+ adjust_priority_for_assoc(OpPriority, RightAssoc, RightPriority),
+ old_term_io.write_term_3(OutStream, Ops, Arg2, RightPriority,
+ !VarSet, !N, !IO),
+ maybe_write_paren(OutStream, ')', Priority, OpPriority, !IO)
+ else if
+ Args = [Arg1, Arg2],
+ Functor = old_term.atom(OpName),
+ ops.lookup_binary_prefix_op(Ops, OpName, OpPriority,
+ FirstAssoc, SecondAssoc)
+ then
+ % ZZZ io.output_stream(OutStream, !IO),
+ maybe_write_paren(OutStream, '(', Priority, OpPriority, !IO),
+ old_term_io.write_constant(OutStream, Functor, !IO),
+ io.write_char(OutStream, ' ', !IO),
+ adjust_priority_for_assoc(OpPriority, FirstAssoc, FirstPriority),
+ old_term_io.write_term_3(OutStream, Ops, Arg1, FirstPriority,
+ !VarSet, !N, !IO),
+ io.write_char(OutStream, ' ', !IO),
+ adjust_priority_for_assoc(OpPriority, SecondAssoc, SecondPriority),
+ old_term_io.write_term_3(OutStream, Ops, Arg2, SecondPriority,
+ !VarSet, !N, !IO),
+ maybe_write_paren(OutStream, ')', Priority, OpPriority, !IO)
+ else
+ ( if
+ Args = [],
+ Functor = old_term.atom(Op),
+ ops.lookup_op(Ops, Op),
+ Priority =< ops.max_priority(Ops)
+ then
+ io.write_char(OutStream, '(', !IO),
+ old_term_io.write_constant(OutStream, Functor, !IO),
+ io.write_char(OutStream, ')', !IO)
+ else
+ old_term_io.write_constant(OutStream, Functor,
+ maybe_adjacent_to_graphic_token, !IO)
+ ),
+ (
+ Args = [X | Xs],
+ io.write_char(OutStream, '(', !IO),
+ old_term_io.write_arg_term(OutStream, Ops, X, !VarSet, !N, !IO),
+ old_term_io.write_term_args(OutStream, Ops, Xs, !VarSet, !N, !IO),
+ io.write_char(OutStream, ')', !IO)
+ ;
+ Args = []
+ )
+ ).
+
+:- pred old_term_io.write_list_tail(io.text_output_stream::in, Ops::in,
+ term(T)::in, varset(T)::in, varset(T)::out, int::in, int::out,
+ io::di, io::uo) is det <= op_table(Ops).
+
+write_list_tail(OutStream, Ops, Term, !VarSet, !N, !IO) :-
+ ( if
+ Term = old_term.variable(Id, _),
+ old_varset.search_var(!.VarSet, Id, Val)
+ then
+ old_term_io.write_list_tail(OutStream, Ops, Val, !VarSet, !N, !IO)
+ else if
+ Term = old_term.functor(old_term.atom("[|]"), [ListHead, ListTail], _)
+ then
+ io.write_string(OutStream, ", ", !IO),
+ old_term_io.write_arg_term(OutStream, Ops, ListHead, !VarSet, !N, !IO),
+ old_term_io.write_list_tail(OutStream, Ops, ListTail, !VarSet, !N, !IO)
+ else if
+ Term = old_term.functor(old_term.atom("[]"), [], _)
+ then
+ true
+ else
+ io.write_string(OutStream, " | ", !IO),
+ old_term_io.write_term_2(OutStream, Ops, Term, !VarSet, !N, !IO)
+ ).
+
+ % Succeeds iff outputting the given term would start with a digit.
+ % (This is a safe, conservative approximation and is used to decide
+ % whether or not to quote infix '.'/2.)
+ %
+:- pred starts_with_digit(term(T)::in) is semidet.
+
+starts_with_digit(functor(integer(_), _, _)).
+starts_with_digit(functor(float(_), _, _)).
+starts_with_digit(functor(atom(Op), Args, _)) :-
+ (
+ Args = [Arg, _],
+ ops.lookup_infix_op(ops.init_mercury_op_table, Op, _, _, _)
+ ;
+ Args = [Arg],
+ ops.lookup_postfix_op(ops.init_mercury_op_table, Op, _, _)
+ ),
+ starts_with_digit(Arg).
+
+%---------------------------------------------------------------------------%
+
+ % Write the remaining arguments.
+ %
+:- pred old_term_io.write_term_args(io.text_output_stream::in, Ops::in,
+ list(term(T))::in, varset(T)::in, varset(T)::out, int::in, int::out,
+ io::di, io::uo) is det <= op_table(Ops).
+
+write_term_args(_, _, [], !VarSet, !N, !IO).
+write_term_args(OutStream, Ops, [X | Xs], !VarSet, !N, !IO) :-
+ io.write_string(OutStream, ", ", !IO),
+ old_term_io.write_arg_term(OutStream, Ops, X, !VarSet, !N, !IO),
+ old_term_io.write_term_args(OutStream, Ops, Xs, !VarSet, !N, !IO).
+
+%---------------------------------------------------------------------------%
+
+write_constant(Const, !IO) :-
+ io.output_stream(OutStream, !IO),
+ write_constant(OutStream, Const, !IO).
+
+write_constant(OutStream, Const, !IO) :-
+ old_term_io.write_constant(OutStream, Const,
+ not_adjacent_to_graphic_token, !IO).
+
+:- pred old_term_io.write_constant(io.text_output_stream::in, const::in,
+ adjacent_to_graphic_token::in, io::di, io::uo) is det.
+
+write_constant(OutStream, Const, NextToGraphicToken, !IO) :-
+ (
+ Const = old_term.integer(I),
+ io.write_int(OutStream, I, !IO)
+ ;
+ Const = old_term.big_integer(Base, I),
+ Prefix = integer_base_prefix(Base),
+ IntString = integer.to_base_string(I, integer_base_int(Base)),
+ io.write_string(OutStream, Prefix, !IO),
+ io.write_string(OutStream, IntString, !IO)
+ ;
+ Const = old_term.float(F),
+ io.write_float(OutStream, F, !IO)
+ ;
+ Const = old_term.atom(A),
+ old_term_io.quote_atom_agt(OutStream, A, NextToGraphicToken, !IO)
+ ;
+ Const = old_term.string(S),
+ old_term_io.quote_string(OutStream, S, !IO)
+ ;
+ Const = old_term.implementation_defined(N),
+ io.write_char(OutStream, '$', !IO),
+ io.write_string(OutStream, N, !IO)
+ ).
+
+format_constant(Const) =
+ old_term_io.format_constant_agt(Const, not_adjacent_to_graphic_token).
+
+:- func old_term_io.format_constant_agt(const, adjacent_to_graphic_token) = string.
+
+format_constant_agt(old_term.integer(I), _) =
+ string.int_to_string(I).
+format_constant_agt(old_term.big_integer(Base, I), _) =
+ integer_base_prefix(Base) ++ to_base_string(I, integer_base_int(Base)).
+format_constant_agt(old_term.float(F), _) =
+ string.float_to_string(F).
+format_constant_agt(old_term.atom(A), NextToGraphicToken) =
+ old_term_io.quoted_atom_agt(A, NextToGraphicToken).
+format_constant_agt(old_term.string(S), _) =
+ old_term_io.quoted_string(S).
+format_constant_agt(old_term.implementation_defined(N), _) =
+ "$" ++ N.
+
+integer_base_int(base_2) = 2.
+integer_base_int(base_8) = 8.
+integer_base_int(base_10) = 10.
+integer_base_int(base_16) = 16.
+
+integer_base_prefix(base_2) = "0b".
+integer_base_prefix(base_8) = "0o".
+integer_base_prefix(base_10) = "".
+integer_base_prefix(base_16) = "0x".
+
+%---------------------------------------------------------------------------%
+
+quote_char(C, !IO) :-
+ io.output_stream(OutStream, !IO),
+ io.write_string(OutStream, old_term_io.quoted_char(C), !IO).
+
+quote_char(Stream, C, !State) :-
+ stream.put(Stream, old_term_io.quoted_char(C), !State).
+
+quoted_char(C) =
+ string.format("'%s'", [s(old_term_io.escaped_char(C))]).
+
+quote_atom(S, !IO) :-
+ old_term_io.quote_atom_agt(S, not_adjacent_to_graphic_token, !IO).
+
+quote_atom(Stream, S, !State) :-
+ old_term_io.quote_atom_agt(Stream, S, not_adjacent_to_graphic_token, !State).
+
+quoted_atom(S) =
+ old_term_io.quoted_atom_agt(S, not_adjacent_to_graphic_token).
+
+quote_atom_agt(S, NextToGraphicToken, !IO) :-
+ io.output_stream(Stream, !IO),
+ old_term_io.quote_atom_agt(Stream, S, NextToGraphicToken, !IO).
+
+quote_atom_agt(Stream, S, NextToGraphicToken, !State) :-
+ ShouldQuote = should_atom_be_quoted(S, NextToGraphicToken),
+ (
+ ShouldQuote = no,
+ stream.put(Stream, S, !State)
+ ;
+ ShouldQuote = yes,
+ stream.put(Stream, '''', !State),
+ old_term_io.write_escaped_string(Stream, S, !State),
+ stream.put(Stream, '''', !State)
+ ).
+
+quoted_atom_agt(S, NextToGraphicToken) = String :-
+ ShouldQuote = should_atom_be_quoted(S, NextToGraphicToken),
+ (
+ ShouldQuote = no,
+ String = S
+ ;
+ ShouldQuote = yes,
+ ES = old_term_io.escaped_string(S),
+ String = string.append_list(["'", ES, "'"])
+ ).
+
+:- func should_atom_be_quoted(string, adjacent_to_graphic_token) = bool.
+
+should_atom_be_quoted(S, NextToGraphicToken) = ShouldQuote :-
+ ( if
+ % I didn't make these rules up: see ISO Prolog 6.3.1.3 and 6.4.2. -fjh
+ (
+ % Letter digit token (6.4.2)
+ string.index(S, 0, FirstChar),
+ char.is_lower(FirstChar),
+ string.is_all_alnum_or_underscore(S)
+ ;
+ % Semicolon token (6.4.2)
+ S = ";"
+ ;
+ % Cut token (6.4.2)
+ S = "!"
+ ;
+ % Graphic token (6.4.2)
+ string.all_match(old_lexer.graphic_token_char, S),
+ S \= "",
+
+ % We need to quote tokens starting with '#', because Mercury uses
+ % '#' to start source line number indicators.
+ not string.index(S, 0, '#'),
+
+ % If the token could be the last token in a term, and the term
+ % could be followed with ".\n", then we need to quote the token,
+ % otherwise the "." would be considered part of the same graphic
+ % token. We can only leave it unquoted if we're sure it won't be
+ % adjacent to any graphic token.
+ NextToGraphicToken = not_adjacent_to_graphic_token
+ ;
+ % 6.3.1.3: atom = open list, close list ;
+ S = "[]"
+ ;
+ % 6.3.1.3: atom = open curly, close curly ;
+ S = "{}"
+ )
+ then
+ ShouldQuote = no
+ else
+ % Anything else must be output as a quoted token (6.4.2).
+ ShouldQuote = yes
+ ).
+
+% Note: the code here is similar to code in compiler/mercury_to_mercury.m;
+% any changes here may require similar changes there.
+
+quote_string(S, !IO) :-
+ io.output_stream(Stream, !IO),
+ old_term_io.quote_string(Stream, S, !IO).
+
+quote_string(Stream, S, !State) :-
+ stream.put(Stream, '"', !State),
+ old_term_io.write_escaped_string(Stream, S, !State),
+ stream.put(Stream, '"', !State).
+
+quoted_string(S) =
+ string.append_list(["""", old_term_io.escaped_string(S), """"]).
+
+write_escaped_string(String, !IO) :-
+ io.output_stream(Stream, !IO),
+ old_term_io.write_escaped_string(Stream, String, !IO).
+
+write_escaped_string(Stream, String, !State) :-
+ string.foldl(old_term_io.write_escaped_char(Stream), String, !State).
+
+escaped_string(String) =
+ string.append_list(
+ reverse(string.foldl(old_term_io.add_escaped_char, String, []))).
+
+:- func old_term_io.add_escaped_char(char, list(string)) = list(string).
+
+add_escaped_char(Char, Strings0) = Strings :-
+ ( if mercury_escape_special_char(Char, QuoteChar) then
+ Strings = [from_char_list(['\\', QuoteChar]) | Strings0]
+ else if is_mercury_source_char(Char) then
+ Strings = [string.char_to_string(Char) | Strings0]
+ else
+ Strings = [mercury_escape_char(Char) | Strings0]
+ ).
+
+% Note: the code of add_escaped_char and write_escaped_char should be
+% kept in sync. The code of both is similar to code in
+% compiler/mercury_to_mercury.m; any changes here may require
+% similar changes there.
+
+write_escaped_char(Char, !IO) :-
+ io.output_stream(Stream, !IO),
+ old_term_io.write_escaped_char(Stream, Char, !IO).
+
+write_escaped_char(Stream, Char, !State) :-
+ ( if mercury_escape_special_char(Char, QuoteChar) then
+ stream.put(Stream, ('\\'), !State),
+ stream.put(Stream, QuoteChar, !State)
+ else if is_mercury_source_char(Char) then
+ stream.put(Stream, Char, !State)
+ else
+ stream.put(Stream, mercury_escape_char(Char), !State)
+ ).
+
+escaped_char(Char) = String :-
+ string_is_escaped_char(Char, String).
+
+:- pragma promise_equivalent_clauses(string_is_escaped_char/2).
+
+string_is_escaped_char(Char::in, String::out) :-
+ ( if mercury_escape_special_char(Char, QuoteChar) then
+ String = string.append("\\", string.char_to_string(QuoteChar))
+ else if is_mercury_source_char(Char) then
+ String = string.char_to_string(Char)
+ else
+ String = mercury_escape_char(Char)
+ ).
+string_is_escaped_char(Char::out, String::in) :-
+ string.to_char_list(String, Chars),
+ (
+ Chars = [Char],
+ (
+ is_mercury_source_char(Char)
+ ;
+ mercury_escape_special_char(Char, _QuoteChar)
+ )
+ ;
+ Chars = ['\\', QuoteChar],
+ mercury_escape_special_char(Char, QuoteChar)
+ ;
+ Chars = ['\\', Char1, Char2, Char3],
+ NumChars = [Char1, Char2, Char3],
+ string.from_char_list(NumChars, NumString),
+ string.base_string_to_int(8, NumString, Int),
+ char.to_int(Char, Int)
+ ).
+
+mercury_escape_char(Char) = EscapeCode :-
+ char.to_int(Char, Int),
+ string.int_to_base_string(Int, 8, OctalString0),
+ string.pad_left(OctalString0, '0', 3, OctalString),
+ EscapeCode = "\\" ++ OctalString ++ "\\".
+
+ % Succeed if Char is a character which is allowed in Mercury string
+ % and character literals.
+ %
+ % Note: the code here is similar to code in compiler/mercury_to_mercury.m;
+ % any changes here may require similar changes there.
+ %
+:- pred is_mercury_source_char(char::in) is semidet.
+
+is_mercury_source_char(Char) :-
+ ( char.is_alnum(Char)
+ ; is_mercury_punctuation_char(Char)
+ ; char.to_int(Char) >= 0x80
+ ).
+
+ % Currently we only allow the following characters.
+ % XXX should we just use is_printable(Char) instead?
+ %
+ % Note: the code here is similar to code in runtime/mercury_trace_base.c;
+ % any changes here may require similar changes there.
+
+is_mercury_punctuation_char(' ').
+is_mercury_punctuation_char('!').
+is_mercury_punctuation_char('@').
+is_mercury_punctuation_char('#').
+is_mercury_punctuation_char('$').
+is_mercury_punctuation_char('%').
+is_mercury_punctuation_char('^').
+is_mercury_punctuation_char('&').
+is_mercury_punctuation_char('*').
+is_mercury_punctuation_char('(').
+is_mercury_punctuation_char(')').
+is_mercury_punctuation_char('-').
+is_mercury_punctuation_char('_').
+is_mercury_punctuation_char('+').
+is_mercury_punctuation_char('=').
+is_mercury_punctuation_char('`').
+is_mercury_punctuation_char('~').
+is_mercury_punctuation_char('{').
+is_mercury_punctuation_char('}').
+is_mercury_punctuation_char('[').
+is_mercury_punctuation_char(']').
+is_mercury_punctuation_char(';').
+is_mercury_punctuation_char(':').
+is_mercury_punctuation_char('''').
+is_mercury_punctuation_char('"').
+is_mercury_punctuation_char('<').
+is_mercury_punctuation_char('>').
+is_mercury_punctuation_char('.').
+is_mercury_punctuation_char(',').
+is_mercury_punctuation_char('/').
+is_mercury_punctuation_char('?').
+is_mercury_punctuation_char('\\').
+is_mercury_punctuation_char('|').
+
+%---------------------------------------------------------------------------%
+
+:- pragma promise_equivalent_clauses(encode_escaped_char/2).
+
+encode_escaped_char(Char::in, Str::out) :-
+ ( if mercury_escape_special_char(Char, EscapeChar) then
+ string.from_char_list(['\\', EscapeChar], Str)
+ else if is_mercury_source_char(Char) then
+ string.from_char_list([Char], Str)
+ else
+ fail
+ ).
+encode_escaped_char(Char::out, Str::in) :-
+ string.to_char_list(Str, Chars),
+ (
+ Chars = [Char]
+ ;
+ Chars = ['\\', EscapedChar],
+ mercury_escape_special_char(Char, EscapedChar)
+ ).
+
+ % mercury_escape_special_char(Char, EscapeChar) is true iff Char
+ % is character for which there is a special backslash-escape character
+ % EscapeChar that can be used after a backslash in string literals or
+ % atoms to represent Char.
+ %
+ % Note: the code here is similar to code in compiler/mercury_to_mercury.m;
+ % any changes here may require similar changes there.
+ %
+:- pred mercury_escape_special_char(char, char).
+:- mode mercury_escape_special_char(in, out) is semidet.
+:- mode mercury_escape_special_char(out, in) is semidet.
+
+mercury_escape_special_char('''', '''').
+mercury_escape_special_char('"', '"').
+mercury_escape_special_char('\\', '\\').
+mercury_escape_special_char('\n', 'n').
+mercury_escape_special_char('\t', 't').
+mercury_escape_special_char('\b', 'b').
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+write_term_nl(VarSet, Term, !IO) :-
+ io.output_stream(OutStream, !IO),
+ write_term_nl(OutStream, VarSet, Term, !IO).
+
+write_term_nl(OutStream, VarSet, Term, !IO) :-
+ io.get_op_table(Ops, !IO),
+ old_term_io.write_term_nl_with_op_table(OutStream, Ops, VarSet, Term, !IO).
+
+write_term_nl_with_op_table(Ops, VarSet, Term, !IO) :-
+ io.output_stream(OutStream, !IO),
+ write_term_nl_with_op_table(OutStream, Ops, VarSet, Term, !IO).
+
+write_term_nl_with_op_table(OutStream, Ops, VarSet, Term, !IO) :-
+ old_term_io.write_term_with_op_table(OutStream, Ops, VarSet, Term, !IO),
+ io.write_string(OutStream, ".\n", !IO).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
diff --git a/extras/old_term_parser/old_term_parser.m b/extras/old_term_parser/old_term_parser.m
index e69de29..38d4177 100644
--- a/extras/old_term_parser/old_term_parser.m
+++ b/extras/old_term_parser/old_term_parser.m
@@ -0,0 +1,16 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+% Copyright (C) 2017 The Mercury team.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+
+:- module old_term_parser.
+:- interface.
+
+:- import_module old_lexer.
+:- import_module old_parser.
+:- import_module old_term.
+:- import_module old_term_io.
+:- import_module old_varset.
diff --git a/extras/old_term_parser/old_varset.m b/extras/old_term_parser/old_varset.m
index e69de29..d141d56 100644
--- a/extras/old_term_parser/old_varset.m
+++ b/extras/old_term_parser/old_varset.m
@@ -0,0 +1,805 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%---------------------------------------------------------------------------%
+% Copyright (C) 1993-2000,2002-2007, 2009-2011 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% File: old_varset.m.
+% Main author: fjh.
+% Stability: low.
+%
+% This file provides facilities for manipulating collections of
+% variables and terms.
+% It provides the 'varset' ADT. A varset is a set of variables.
+% (These variables are object-level variables, and are represented
+% as ground terms, so it might help to think of them as "variable ids"
+% rather than variables.)
+% Associated with each variable there can be both a name and a value
+% (binding).
+%
+% There may be some design flaws in the relationship between varset.m, and
+% old_term.m. Once we have implemented unique modes and destructive assignment, we
+% will need to rethink the design; we may end up modifying these modules
+% considerably, or we may end up making new single-threaded versions of these
+% modules.
+%
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- module old_varset.
+:- interface.
+
+:- import_module assoc_list.
+:- import_module list.
+:- import_module map.
+:- import_module maybe.
+:- import_module set.
+:- import_module old_term.
+
+%---------------------------------------------------------------------------%
+
+:- type varset(T).
+
+:- type varset == varset(generic).
+
+%---------------------%
+
+ % Construct an empty varset.
+ %
+:- func init = varset(T).
+:- pred init(varset(T)::out) is det.
+
+ % Check whether a varset is empty.
+ %
+:- pred is_empty(varset(T)::in) is semidet.
+
+%---------------------%
+
+ % Create a new variable.
+ %
+:- pred new_var(var(T)::out, varset(T)::in, varset(T)::out) is det.
+
+ % Create a new named variable.
+ %
+:- pred new_named_var(string::in, var(T)::out,
+ varset(T)::in, varset(T)::out) is det.
+
+ % Create a new named variable with a unique (w.r.t. the
+ % varset) number appended to the name.
+ %
+:- pred new_uniquely_named_var(string::in, var(T)::out,
+ varset(T)::in, varset(T)::out) is det.
+
+ % Create a new variable, and maybe give it a name.
+ %
+:- pred new_maybe_named_var(maybe(string)::in, var(T)::out,
+ varset(T)::in, varset(T)::out) is det.
+
+ % Create multiple new variables.
+ %
+:- pred new_vars(int::in, list(var(T))::out,
+ varset(T)::in, varset(T)::out) is det.
+
+%---------------------%
+
+ % Delete the name and value for a variable.
+ %
+:- func delete_var(varset(T), var(T)) = varset(T).
+:- pred delete_var(var(T)::in, varset(T)::in, varset(T)::out) is det.
+
+ % Delete the names and values for a list of variables.
+ %
+:- func delete_vars(varset(T), list(var(T))) = varset(T).
+:- pred delete_vars(list(var(T))::in, varset(T)::in, varset(T)::out)
+ is det.
+
+ % Delete the names and values for a sorted list of variables.
+ % (If the list is not sorted, the result will be either an abort
+ % or incorrect output.)
+ %
+:- func delete_sorted_vars(varset(T), list(var(T))) = varset(T).
+:- pred delete_sorted_vars(list(var(T))::in,
+ varset(T)::in, varset(T)::out) is det.
+
+%---------------------%
+
+ % Return a list of all the variables in a varset.
+ %
+:- func vars(varset(T)) = list(var(T)).
+:- pred vars(varset(T)::in, list(var(T))::out) is det.
+
+%---------------------%
+
+ % Set the name of a variable.
+ %
+:- func name_var(varset(T), var(T), string) = varset(T).
+:- pred name_var(var(T)::in, string::in,
+ varset(T)::in, varset(T)::out) is det.
+
+ % Lookup the name of a variable;
+ % If it doesn't have one, create on using V_ as a prefix.
+ %
+:- func lookup_name(varset(T), var(T)) = string.
+:- pred lookup_name(varset(T)::in, var(T)::in, string::out) is det.
+
+ % Lookup the name of a variable;
+ % if it doesn't have one, create one using the specified prefix.
+ %
+:- func lookup_name(varset(T), var(T), string) = string.
+:- pred lookup_name(varset(T)::in, var(T)::in, string::in, string::out)
+ is det.
+
+ % Lookup the name of a variable;
+ % fail if it doesn't have one.
+ %
+:- pred search_name(varset(T)::in, var(T)::in, string::out) is semidet.
+
+%---------------------%
+
+ % Bind a value to a variable.
+ % This will overwrite any existing binding.
+ %
+:- func bind_var(varset(T), var(T), term(T)) = varset(T).
+:- pred bind_var(var(T)::in, term(T)::in,
+ varset(T)::in, varset(T)::out) is det.
+
+ % Bind a set of terms to a set of variables.
+ %
+:- func bind_vars(varset(T), substitution(T)) = varset(T).
+:- pred bind_vars(substitution(T)::in,
+ varset(T)::in, varset(T)::out) is det.
+
+ % Lookup the value of a variable.
+ %
+:- pred search_var(varset(T)::in, var(T)::in, term(T)::out) is semidet.
+
+%---------------------%
+
+ % Get the bindings for all the bound variables.
+ %
+ % NOTE_TO_IMPLEMENTORS Redundant; identical to get_bindings.
+:- func lookup_vars(varset(T)) = substitution(T).
+:- pred lookup_vars(varset(T)::in, substitution(T)::out) is det.
+
+ % Get the bindings for all the bound variables.
+ %
+:- func get_bindings(varset(T)) = substitution(T).
+:- pred get_bindings(varset(T)::in, substitution(T)::out) is det.
+
+ % Set the bindings for all the bound variables.
+ %
+ % NOTE_TO_IMPLEMENTORS The argument order is not conducive
+ % NOTE_TO_IMPLEMENTORS to the use of state variables.
+:- func set_bindings(varset(T), substitution(T)) = varset(T).
+:- pred set_bindings(varset(T)::in, substitution(T)::in,
+ varset(T)::out) is det.
+
+%---------------------%
+
+ % Combine two different varsets, renaming apart:
+ % merge_renaming(VarSet0, NewVarSet, VarSet, Subst) is true
+ % iff VarSet is the varset that results from joining a suitably renamed
+ % version of NewVarSet to VarSet0. (Any bindings in NewVarSet are ignored.)
+ % Renaming will map each variable in NewVarSet to the corresponding
+ % fresh variable in VarSet.
+ %
+:- pred merge_renaming(varset(T)::in, varset(T)::in, varset(T)::out,
+ renaming(T)::out) is det.
+
+ % Same as merge_renaming, except that the names of variables
+ % in NewVarSet are not included in the final varset.
+ % This is useful if create_name_var_map needs to be used
+ % on the resulting varset.
+ %
+:- pred merge_renaming_without_names(varset(T)::in,
+ varset(T)::in, varset(T)::out, renaming(T)::out) is det.
+
+ % Does the same job as merge_renaming, but returns the renaming
+ % as a general substitution in which all the terms in the range happen
+ % to be variables.
+ %
+ % Consider using merge_renaming instead.
+ %
+:- pred merge_subst(varset(T)::in, varset(T)::in, varset(T)::out,
+ substitution(T)::out) is det.
+:- pragma obsolete(merge_subst/4).
+
+ % Same as merge_subst, except that the names of variables
+ % in NewVarSet are not included in the final varset.
+ % This is useful if create_name_var_map needs to be used
+ % on the resulting varset.
+ %
+ % Consider using merge_renaming_without_names instead.
+ %
+:- pred merge_subst_without_names(varset(T)::in,
+ varset(T)::in, varset(T)::out, substitution(T)::out) is det.
+:- pragma obsolete(merge_subst_without_names/4).
+
+ % merge(VarSet0, NewVarSet, Terms0, VarSet, Terms):
+ %
+ % As merge_renaming, except instead of returning the renaming,
+ % this predicate applies it to the given list of terms.
+ %
+:- pred merge(varset(T)::in, varset(T)::in, list(term(T))::in,
+ varset(T)::out, list(term(T))::out) is det.
+
+ % Same as merge, except that the names of variables
+ % in NewVarSet are not included in the final varset.
+ % This is useful if create_name_var_map needs to be used
+ % on the resulting varset.
+ %
+:- pred merge_without_names(varset(T)::in, varset(T)::in,
+ list(term(T))::in, varset(T)::out, list(term(T))::out) is det.
+
+%---------------------%
+
+ % Create a map from names to variables.
+ % Each name is mapped to only one variable, even if a name is
+ % shared by more than one variable. Therefore this predicate
+ % is only really useful if it is already known that no two
+ % variables share the same name.
+ %
+:- func create_name_var_map(varset(T)) = map(string, var(T)).
+:- pred create_name_var_map(varset(T)::in, map(string, var(T))::out)
+ is det.
+
+ % Return an association list giving the name of each variable.
+ % Every variable has an entry in the returned association list,
+ % even if it shares its name with another variable.
+ %
+:- func var_name_list(varset(T)) = assoc_list(var(T), string).
+:- pred var_name_list(varset(T)::in, assoc_list(var(T), string)::out)
+ is det.
+
+ % Given a list of variable and varset in which some variables have
+ % no name but some other variables may have the same name,
+ % return another varset in which every variable has a unique name.
+ % If necessary, names will have suffixes added on the end;
+ % the second argument gives the suffix to use.
+ %
+:- func ensure_unique_names(list(var(T)), string, varset(T))
+ = varset(T).
+:- pred ensure_unique_names(list(var(T))::in,
+ string::in, varset(T)::in, varset(T)::out) is det.
+
+%---------------------%
+
+ % Given a varset and a set of variables, remove the names
+ % and values of any other variables stored in the varset.
+ %
+:- func select(varset(T), set(var(T))) = varset(T).
+:- pred select(set(var(T))::in, varset(T)::in, varset(T)::out) is det.
+
+ % Given a varset and a list of variables, construct a new varset
+ % containing one variable for each one in the list (and no others).
+ % Also return a substitution mapping the selected variables in the
+ % original varset into variables in the new varset. The relative
+ % ordering of variables in the original varset is maintained.
+ %
+:- pred squash(varset(T)::in, list(var(T))::in,
+ varset(T)::out, renaming(T)::out) is det.
+
+ % Coerce the types of the variables in a varset.
+ %
+:- func coerce(varset(T)) = varset(U).
+:- pred coerce(varset(T)::in, varset(U)::out) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+% Everything below here is not intended to be part of the public interface,
+% and will not be included in the Mercury library reference manual.
+
+:- interface.
+
+ % Returns the highest numbered variable returned from this varset's
+ % var_supply.
+ %
+:- func max_var(varset(T)) = var(T).
+
+:- func num_allocated(varset(T)) = int.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module pair.
+:- import_module require.
+:- import_module string.
+
+:- type varset(T)
+ ---> varset(
+ var_supply :: var_supply(T),
+ var_names :: map(var(T), string),
+ var_values :: map(var(T), term(T))
+ ).
+
+%---------------------------------------------------------------------------%
+
+init = VarSet :-
+ old_varset.init(VarSet).
+
+init(VarSet) :-
+ old_term.init_var_supply(VarSupply),
+ map.init(Names),
+ map.init(Values),
+ VarSet = varset(VarSupply, Names, Values).
+
+%---------------------------------------------------------------------------%
+
+is_empty(varset(VarSupply, _, _)) :-
+ old_term.init_var_supply(VarSupply).
+
+%---------------------------------------------------------------------------%
+
+new_var(Var, !VarSet) :-
+ MaxId0 = !.VarSet ^ var_supply,
+ old_term.create_var(Var, MaxId0, MaxId),
+ !VarSet ^ var_supply := MaxId.
+
+new_named_var(Name, Var, !VarSet) :-
+ !.VarSet = varset(MaxId0, Names0, Values),
+ old_term.create_var(Var, MaxId0, MaxId),
+ map.set(Var, Name, Names0, Names),
+ !:VarSet = varset(MaxId, Names, Values).
+
+new_uniquely_named_var(Name, Var, !VarSet) :-
+ !.VarSet = varset(MaxId0, Names0, Values),
+ old_term.create_var(Var, MaxId0, MaxId),
+ N = old_term.var_to_int(Var),
+ map.set(Var, string.format("%s_%d", [s(Name), i(N)]), Names0, Names),
+ !:VarSet = varset(MaxId, Names, Values).
+
+new_maybe_named_var(MaybeName, Var, !VarSet) :-
+ !.VarSet = varset(MaxId0, Names0, Values),
+ old_term.create_var(Var, MaxId0, MaxId),
+ (
+ MaybeName = no,
+ Names = Names0
+ ;
+ MaybeName = yes(Name),
+ map.set(Var, Name, Names0, Names)
+ ),
+ !:VarSet = varset(MaxId, Names, Values).
+
+new_vars(NumVars, NewVars, !VarSet) :-
+ old_varset.new_vars_loop(NumVars, [], RevNewVars, !VarSet),
+ % Return the new variables in order.
+ list.reverse(RevNewVars, NewVars).
+
+:- pred old_varset.new_vars_loop(int::in, list(var(T))::in,
+ list(var(T))::out, varset(T)::in, varset(T)::out) is det.
+
+new_vars_loop(NumVars, !RevNewVars, !VarSet) :-
+ ( if NumVars > 0 then
+ old_varset.new_var(Var, !VarSet),
+ !:RevNewVars = [Var | !.RevNewVars],
+ old_varset.new_vars_loop(NumVars - 1, !RevNewVars, !VarSet)
+ else if NumVars = 0 then
+ true
+ else
+ unexpected($module, $pred, "invalid call")
+ ).
+
+%---------------------------------------------------------------------------%
+
+delete_var(!.VarSet, DeleteVar) = !:VarSet :-
+ old_varset.delete_var(DeleteVar, !VarSet).
+
+delete_var(DeleteVar, !VarSet) :-
+ !.VarSet = varset(MaxId, Names0, Values0),
+ map.delete(DeleteVar, Names0, Names),
+ map.delete(DeleteVar, Values0, Values),
+ !:VarSet = varset(MaxId, Names, Values).
+
+%---------------------------------------------------------------------------%
+
+delete_vars(!.VarSet, DeleteVars) = !:VarSet :-
+ old_varset.delete_vars(DeleteVars, !VarSet).
+
+delete_vars(DeleteVars, !VarSet) :-
+ !.VarSet = varset(MaxId, Names0, Values0),
+ map.delete_list(DeleteVars, Names0, Names),
+ map.delete_list(DeleteVars, Values0, Values),
+ !:VarSet = varset(MaxId, Names, Values).
+
+delete_sorted_vars(!.VarSet, DeleteVars) = !:VarSet :-
+ old_varset.delete_sorted_vars(DeleteVars, !VarSet).
+
+delete_sorted_vars(DeleteVars, !VarSet) :-
+ !.VarSet = varset(MaxId, Names0, Values0),
+ map.delete_sorted_list(DeleteVars, Names0, Names),
+ map.delete_sorted_list(DeleteVars, Values0, Values),
+ !:VarSet = varset(MaxId, Names, Values).
+
+%---------------------------------------------------------------------------%
+
+vars(VarSet) = Vars :-
+ old_varset.vars(VarSet, Vars).
+
+vars(VarSet, Vars) :-
+ MaxId = VarSet ^ var_supply,
+ old_term.init_var_supply(N0),
+ old_varset.vars_loop(N0, MaxId, [], RevVars),
+ list.reverse(RevVars, Vars).
+
+:- pred old_varset.vars_loop(var_supply(T)::in, var_supply(T)::in,
+ list(var(T))::in, list(var(T))::out) is det.
+
+vars_loop(Cur, Max, !RevVars) :-
+ ( if Cur = Max then
+ true
+ else
+ old_term.create_var(Var, Cur, Next),
+ !:RevVars = [Var | !.RevVars],
+ old_varset.vars_loop(Next, Max, !RevVars)
+ ).
+
+%---------------------------------------------------------------------------%
+
+name_var(!.VarSet, Var, Name) = !:VarSet :-
+ old_varset.name_var(Var, Name, !VarSet).
+
+name_var(Var, Name, !VarSet) :-
+ Names0 = !.VarSet ^ var_names,
+ map.set(Var, Name, Names0, Names),
+ !VarSet ^ var_names := Names.
+
+%---------------------------------------------------------------------------%
+
+lookup_name(VarSet, Var) = Name :-
+ old_varset.lookup_name(VarSet, Var, Name).
+
+lookup_name(VarSet, Var, Name) :-
+ ( if old_varset.search_name(VarSet, Var, NamePrime) then
+ Name = NamePrime
+ else
+ old_term.var_to_int(Var, VarNum),
+ Name = "V_" ++ string.int_to_string(VarNum)
+ ).
+
+lookup_name(VarSet, Id, Prefix) = Name :-
+ old_varset.lookup_name(VarSet, Id, Prefix, Name).
+
+lookup_name(VarSet, Id, Prefix, Name) :-
+ ( if old_varset.search_name(VarSet, Id, NamePrime) then
+ Name = NamePrime
+ else
+ old_term.var_to_int(Id, VarNum),
+ Name = Prefix ++ string.int_to_string(VarNum)
+ ).
+
+search_name(VarSet, Var, Name) :-
+ VarSet = varset(_, Names, _),
+ map.search(Names, Var, Name).
+
+%---------------------------------------------------------------------------%
+
+bind_var(!.VarSet, Var, Value) = !:VarSet :-
+ old_varset.bind_var(Var, Value, !VarSet).
+
+bind_var(Var, Value, !VarSet) :-
+ Values0 = !.VarSet ^ var_values,
+ map.set(Var, Value, Values0, Values),
+ !VarSet ^ var_values := Values.
+
+%---------------------------------------------------------------------------%
+
+bind_vars(!.VarSet, Subst) = !:VarSet :-
+ old_varset.bind_vars(Subst, !VarSet).
+
+bind_vars(Subst, !VarSet) :-
+ map.to_assoc_list(Subst, VarsValues),
+ old_varset.bind_vars_loop(VarsValues, !VarSet).
+
+:- pred old_varset.bind_vars_loop(assoc_list(var(T), term(T))::in, varset(T)::in,
+ varset(T)::out) is det.
+
+bind_vars_loop([], !VarSet).
+bind_vars_loop([Var - Value | VarsValues], !VarSet) :-
+ old_varset.bind_var(Var, Value, !VarSet),
+ old_varset.bind_vars_loop(VarsValues, !VarSet).
+
+%---------------------------------------------------------------------------%
+
+search_var(VarSet, Var, Value) :-
+ Values = VarSet ^ var_values,
+ map.search(Values, Var, Value).
+
+%---------------------------------------------------------------------------%
+
+lookup_vars(VarSet) = Values :-
+ old_varset.lookup_vars(VarSet, Values).
+
+lookup_vars(VarSet, Values) :-
+ Values = VarSet ^ var_values.
+
+%---------------------------------------------------------------------------%
+
+get_bindings(VarSet) = Values :-
+ old_varset.get_bindings(VarSet, Values).
+
+get_bindings(VarSet, Values) :-
+ Values = VarSet ^ var_values.
+
+set_bindings(!.VarSet, Values) = !:VarSet :-
+ old_varset.set_bindings(!.VarSet, Values, !:VarSet).
+
+set_bindings(!.VarSet, Values, !:VarSet) :-
+ !VarSet ^ var_values := Values.
+
+%---------------------------------------------------------------------------%
+%
+% We scan through the second varset, introducing a fresh variable
+% into the first varset for each var in the second, and building up
+% a renaming which maps the variables in the second varset into
+% the corresponding fresh variable in the first old_varset.
+%
+% The structure of this code is identical to the structure of the code
+% in the next block.
+%
+
+merge_renaming(VarSetA, VarSetB, VarSet, Renaming) :-
+ VarSetB = varset(SupplyB, NamesB, _ValuesB),
+ old_term.init_var_supply(SupplyB0),
+ VarSetA = varset(SupplyA, NamesA, ValuesA),
+ map.init(Renaming0),
+ old_varset.merge_renaming_loop(SupplyB0, SupplyB, NamesB,
+ SupplyA, Supply, NamesA, Names, Renaming0, Renaming),
+ VarSet = varset(Supply, Names, ValuesA).
+
+:- pred old_varset.merge_renaming_loop(var_supply(T)::in, var_supply(T)::in,
+ map(var(T), string)::in,
+ var_supply(T)::in, var_supply(T)::out,
+ map(var(T), string)::in, map(var(T), string)::out,
+ renaming(T)::in, renaming(T)::out) is det.
+
+merge_renaming_loop(!.SupplyB, MaxSupplyB, NamesB,
+ !Supply, !Names, !Renaming) :-
+ ( if !.SupplyB = MaxSupplyB then
+ true
+ else
+ old_term.create_var(Var, !Supply),
+ old_term.create_var(VarB, !SupplyB),
+ ( if map.search(NamesB, VarB, NameB) then
+ map.det_insert(Var, NameB, !Names)
+ else
+ true
+ ),
+ map.det_insert(VarB, Var, !Renaming),
+ old_varset.merge_renaming_loop(!.SupplyB, MaxSupplyB, NamesB,
+ !Supply, !Names, !Renaming)
+ ).
+
+merge_renaming_without_names(VarSetA, VarSetB, VarSet, Renaming) :-
+ VarSetB = varset(SupplyB, _NamesB, _ValuesB),
+ old_term.init_var_supply(SupplyB0),
+ VarSetA = varset(SupplyA, NamesA, ValuesA),
+ map.init(Renaming0),
+ old_varset.merge_renaming_without_names_loop(SupplyB0, SupplyB,
+ SupplyA, Supply, Renaming0, Renaming),
+ VarSet = varset(Supply, NamesA, ValuesA).
+
+:- pred old_varset.merge_renaming_without_names_loop(var_supply(T)::in,
+ var_supply(T)::in, var_supply(T)::in, var_supply(T)::out,
+ renaming(T)::in, renaming(T)::out) is det.
+
+merge_renaming_without_names_loop(!.SupplyB, MaxSupplyB,
+ !Supply, !Renaming) :-
+ ( if !.SupplyB = MaxSupplyB then
+ true
+ else
+ old_term.create_var(Var, !Supply),
+ old_term.create_var(VarB, !SupplyB),
+ map.det_insert(VarB, Var, !Renaming),
+ old_varset.merge_renaming_without_names_loop(!.SupplyB, MaxSupplyB,
+ !Supply, !Renaming)
+ ).
+
+%---------------------------------------------------------------------------%
+%
+% The structure of this code is identical to the structure of the code
+% in the previous block.
+
+merge_subst(VarSetA, VarSetB, VarSet, Subst) :-
+ VarSetB = varset(SupplyB, NamesB, _ValuesB),
+ old_term.init_var_supply(SupplyB0),
+ VarSetA = varset(SupplyA, NamesA, ValuesA),
+ map.init(Subst0),
+ old_varset.merge_subst_loop(SupplyB0, SupplyB, NamesB,
+ SupplyA, Supply, NamesA, Names, Subst0, Subst),
+ VarSet = varset(Supply, Names, ValuesA).
+
+:- pred old_varset.merge_subst_loop(var_supply(T)::in, var_supply(T)::in,
+ map(var(T), string)::in,
+ var_supply(T)::in, var_supply(T)::out,
+ map(var(T), string)::in, map(var(T), string)::out,
+ substitution(T)::in, substitution(T)::out) is det.
+
+merge_subst_loop(!.SupplyB, MaxSupplyB, NamesB,
+ !Supply, !Names, !Subst) :-
+ ( if !.SupplyB = MaxSupplyB then
+ true
+ else
+ old_term.create_var(Var, !Supply),
+ old_term.create_var(VarB, !SupplyB),
+ ( if map.search(NamesB, VarB, NameB) then
+ map.det_insert(Var, NameB, !Names)
+ else
+ true
+ ),
+ Replacement = old_term.variable(Var, context_init),
+ map.det_insert(VarB, Replacement, !Subst),
+ old_varset.merge_subst_loop(!.SupplyB, MaxSupplyB, NamesB,
+ !Supply, !Names, !Subst)
+ ).
+
+merge_subst_without_names(VarSetA, VarSetB, VarSet, Subst) :-
+ VarSetB = varset(SupplyB, _NamesB, _ValuesB),
+ old_term.init_var_supply(SupplyB0),
+ VarSetA = varset(SupplyA, NamesA, ValuesA),
+ map.init(Subst0),
+ old_varset.merge_subst_without_names_loop(SupplyB0, SupplyB,
+ SupplyA, Supply, Subst0, Subst),
+ VarSet = varset(Supply, NamesA, ValuesA).
+
+:- pred old_varset.merge_subst_without_names_loop( var_supply(T)::in,
+ var_supply(T)::in, var_supply(T)::in, var_supply(T)::out,
+ substitution(T)::in, substitution(T)::out) is det.
+
+merge_subst_without_names_loop(!.SupplyB, MaxSupplyB,
+ !Supply, !Subst) :-
+ ( if !.SupplyB = MaxSupplyB then
+ true
+ else
+ old_term.create_var(Var, !Supply),
+ old_term.create_var(VarB, !SupplyB),
+ Replacement = old_term.variable(Var, context_init),
+ map.det_insert(VarB, Replacement, !Subst),
+ old_varset.merge_subst_without_names_loop(!.SupplyB, MaxSupplyB,
+ !Supply, !Subst)
+ ).
+
+%---------------------------------------------------------------------------%
+
+merge(VarSetA, VarSetB, TermList0, VarSet, TermList) :-
+ old_varset.merge_renaming(VarSetA, VarSetB, VarSet, Renaming),
+ old_term.apply_renaming_in_terms(Renaming, TermList0, TermList).
+
+merge_without_names(VarSetA, VarSetB, TermList0, VarSet, TermList) :-
+ old_varset.merge_renaming_without_names(VarSetA, VarSetB, VarSet, Renaming),
+ old_term.apply_renaming_in_terms(Renaming, TermList0, TermList).
+
+%---------------------------------------------------------------------------%
+
+create_name_var_map(VarSet) = NameVars :-
+ old_varset.create_name_var_map(VarSet, NameVars).
+
+create_name_var_map(VarSet, NameVars) :-
+ VarNames = VarSet ^ var_names,
+ map.keys(VarNames, Vars),
+ map.values(VarNames, Names),
+ map.from_corresponding_lists(Names, Vars, NameVars).
+
+%---------------------------------------------------------------------------%
+
+var_name_list(VarSet) = VarNameList :-
+ old_varset.var_name_list(VarSet, VarNameList).
+
+var_name_list(VarSet, VarNameList) :-
+ VarNames = VarSet ^ var_names,
+ map.to_assoc_list(VarNames, VarNameList).
+
+%---------------------------------------------------------------------------%
+
+ensure_unique_names(AllVars, Suffix, !.VarSet) = !:VarSet :-
+ old_varset.ensure_unique_names(AllVars, Suffix, !VarSet).
+
+ensure_unique_names(AllVars, Suffix, !VarSet) :-
+ VarNames0 = !.VarSet ^ var_names,
+ old_varset.ensure_unique_names_loop(AllVars, Suffix, set.init, VarNames0,
+ map.init, VarNames),
+ !VarSet ^ var_names := VarNames.
+
+:- pred old_varset.ensure_unique_names_loop(list(var(T))::in, string::in,
+ set(string)::in, map(var(T), string)::in, map(var(T), string)::in,
+ map(var(T), string)::out) is det.
+
+ensure_unique_names_loop([], _, _, _, !VarNames).
+ensure_unique_names_loop([Var | Vars], Suffix, !.UsedNames,
+ OldVarNames, !VarNames) :-
+ ( if map.search(OldVarNames, Var, OldName) then
+ ( if set.member(OldName, !.UsedNames) then
+ old_term.var_to_int(Var, VarNum),
+ TrialName = OldName ++ "_" ++ string.int_to_string(VarNum)
+ else
+ TrialName = OldName
+ )
+ else
+ old_term.var_to_int(Var, VarNum),
+ TrialName = "Var_" ++ string.int_to_string(VarNum)
+ ),
+ append_suffix_until_unique(TrialName, Suffix, !.UsedNames, FinalName),
+ set.insert(FinalName, !UsedNames),
+ map.det_insert(Var, FinalName, !VarNames),
+ old_varset.ensure_unique_names_loop(Vars, Suffix, !.UsedNames,
+ OldVarNames, !VarNames).
+
+:- pred append_suffix_until_unique(string::in, string::in, set(string)::in,
+ string::out) is det.
+
+append_suffix_until_unique(Trial0, Suffix, UsedNames, Final) :-
+ ( if set.member(Trial0, UsedNames) then
+ string.append(Trial0, Suffix, Trial1),
+ append_suffix_until_unique(Trial1, Suffix, UsedNames, Final)
+ else
+ Final = Trial0
+ ).
+
+%---------------------------------------------------------------------------%
+
+select(!.VarSet, Vars) = !:VarSet :-
+ old_varset.select(Vars, !VarSet).
+
+select(Vars, !VarSet) :-
+ !.VarSet = varset(Supply, VarNameMap0, Values0),
+ map.select(VarNameMap0, Vars, VarNameMap),
+ map.select(Values0, Vars, Values),
+ !:VarSet = varset(Supply, VarNameMap, Values).
+
+%---------------------------------------------------------------------------%
+
+squash(OldVarSet, KeptVars, NewVarSet, Subst) :-
+ % Create a new varset with the same number of variables.
+ list.length(KeptVars, NumVars),
+ old_varset.init(NewVarSet0),
+ old_varset.new_vars(NumVars, NewVars0, NewVarSet0, NewVarSet1),
+
+ % We need to sort the fresh variables, to ensure that the substitution
+ % that we create below does not alter the relative ordering of the
+ % variables.
+ list.sort(NewVars0, NewVars),
+
+ % Copy the variable names across from the old varset to the new varset.
+ old_varset.var_name_list(OldVarSet, VarNames),
+ map.from_corresponding_lists(KeptVars, NewVars, Subst),
+ copy_var_names(VarNames, Subst, NewVarSet1, NewVarSet).
+
+:- pred copy_var_names(assoc_list(var(T), string)::in, renaming(T)::in,
+ varset(T)::in, varset(T)::out) is det.
+
+copy_var_names([], _Subst, !NewVarSet).
+copy_var_names([OldVar - Name | Rest], Subst, !NewVarSet) :-
+ ( if map.search(Subst, OldVar, NewVar) then
+ old_varset.name_var(NewVar, Name, !NewVarSet)
+ else
+ true
+ ),
+ copy_var_names(Rest, Subst, !NewVarSet).
+
+%---------------------------------------------------------------------------%
+
+coerce(!.VarSet) = !:VarSet :-
+ old_varset.coerce(!VarSet).
+
+coerce(!VarSet) :-
+ % Normally calls to this predicate should only be generated by the
+ % compiler, but type coercion by copying was taking about 3% of the
+ % compiler's runtime.
+ private_builtin.unsafe_type_cast(!VarSet).
+
+%---------------------------------------------------------------------------%
+
+max_var(varset(VarSupply, _, _)) = old_term.var_supply_max_var(VarSupply).
+
+num_allocated(varset(VarSupply, _, _)) =
+ old_term.var_supply_num_allocated(VarSupply).
+
+%---------------------------------------------------------------------------%
+:- end_module old_varset.
+%---------------------------------------------------------------------------%
More information about the reviews
mailing list