Files
mercury/extras/morphine/source/display.op
Erwan Jahier fb8a1055c7 Fix a cut and paste error when I added line numbers in the
Estimated hours taken: .2
branches: main.

extras/morphine/source/display.op
	Fix a cut and paste error when I added line numbers in the
	morphine trace.
2001-07-19 11:35:16 +00:00

1598 lines
40 KiB
Plaintext

%------------------------------------------------------------------------------%
% Copyright (C) 1999-2001 INRIA/INSA de Rennes/IFSIC.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file License in the Morphine distribution.
%
% Author : Erwan Jahier <jahier@irisa.fr>
%
opium_scenario(
name : display,
files : [display],
scenarios : [],
message :
"Scenario which contains everything related to the display of trace \
events. In particular the attributes to be displayed can be specified, as \
well as the way lists and terms are displayed. Arguments of predicates \
can be skipped. Many procedures allow you to customize the display.\
"
).
%------------------------------------------------------------------------------%
opium_command(
name : print_event,
arg_list : [],
arg_type_list : [],
abbrev : p,
interface : button,
command_type : opium,
implementation : print_event_Op,
parameters : [indent_display, attribute_display, arg_undisplay,
list_display, term_display],
message :
"Prints the current trace event according to the value of the \
display parameters. The name of the printed attributes can be get with the \
command `print_displayed_attributes/0'.\
"
).
% :- pred print_event is det.
print_event_Op :-
( getval(state_of_morphine, running) ->
attribute_display(ChronoFlag, CallFlag, PortFlag, DepthFlag, DeterFlag,
PredOrFuncFlag, DeclModuleFlag, DefModuleFlag,
NameFlag, ArityFlag, ModeNumFlag, ArgFlag,
ListVarFlag, TypeFlag, GoalPathFlag, LineNumberFlag),
current_attributes(Chrono, Call, Depth, Port, PredOrFunc, DeclModule,
DefModule, Name, Arity, ModeNum, Deter, GoalPath, LineNumber),
indent_display(IndentFlag, IndentValue, IndentDepth),
print_line_attribute(chrono, Chrono, ChronoFlag),
write_indent(IndentFlag, IndentValue, IndentDepth, Depth),
print_line_attribute(call, Call, CallFlag),
print_line_attribute(depth, Depth, DepthFlag),
print_line_attribute(port, Port, PortFlag),
print_line_attribute(deter, Deter, DeterFlag),
print_line_attribute(proc_type, PredOrFunc, PredOrFuncFlag),
print_line_attribute(def_module, DefModule, DefModuleFlag),
print_line_attribute(decl_module, DeclModule, DeclModuleFlag),
print_line_attribute(name, Name, NameFlag),
(
(ArgFlag = 'on' ; ListVarFlag = 'on' ; TypeFlag = 'on')
->
% This is to turn around the fact that Mireille redefine of
% precedence of 400 for the operator`:', which prevents
% variables of the form: `e-g:foo' to unify with `Arg:Type'.
current_op(Precedence, Assoc, ':'),
op(600, xfy, ':'),
% We only retrieve live variable if they are needed
( current_vars(ListArg, ListVar) ->
write_arg_attribute(DeclModule:Name/Arity-ModeNum,
ListArg, ArgFlag, TypeFlag)
;
% sometimes, current_vars fails...,
write_trace("(*** Software Error in current_vars/2)")
),
op(Precedence, Assoc, ':')
;
write_trace("()")
),
print_line_attribute(arity, Arity, ArityFlag),
print_line_attribute(mode_number, ModeNum, ModeNumFlag),
print_line_attribute(goal_path, GoalPath, GoalPathFlag),
print_line_attribute(line_number, LineNumber, LineNumberFlag),
print_line_attribute(listvar, ListVar, ListVarFlag),
write_trace('\n')
;
write("You can't print any trace line; No program is running.\n")
),!.
print_event_Op :-
write("Sofware error in scenario display.op: print_event/0 failed.\n").
%:- pred print_line_attribute(atom, atom ,atom).
%:- mode print_line_attribute(in, in, in) is det.
print_line_attribute(_AttributeName, _AttributeValue, off).
print_line_attribute(AttributeName, AttributeValue, on) :-
write_attribute(AttributeName, AttributeValue).
%------------------------------------------------------------------------------%
opium_command(
name : print_displayed_attributes,
arg_list : [],
arg_type_list : [],
abbrev : _,
interface : hidden,
command_type : opium,
implementation : print_displayed_attributes_Op,
parameters : [indent_display, attribute_display, arg_undisplay,
list_display, term_display],
message :
"Prints the names of the attributes displayed by `print_event/0'.\
"
).
% :- pred print_displayed_attributes_Op is det.
print_displayed_attributes_Op :-
attribute_display(ChronoFlag, CallFlag, PortFlag, DepthFlag, DeterFlag,
PredOrFuncFlag, DeclModuleFlag, DefModuleFlag,
NameFlag, ArityFlag, ModeNumFlag, ArgFlag,
ListVarFlag, TypeFlag, GoalPathFlag, LineNumFlag),
indent_display(IndentFlag, IndentValue, IndentDepth),
(ChronoFlag = on -> write_trace("chrono: ") ; true),
write_indent(IndentFlag, IndentValue, IndentDepth, 1),
print_line_attribute(call, call, CallFlag),
print_line_attribute(depth, depth, DepthFlag),
print_line_attribute(port, port, PortFlag),
print_line_attribute(deter, deter, DeterFlag),
print_line_attribute(proc_type, PredOrFunc, PredOrFuncFlag),
print_line_attribute(def_module, Defmodule, DefModuleFlag),
print_line_attribute(decl_module, Declmodule, DeclModuleFlag),
print_line_attribute(name, name, NameFlag),
(
ArgFlag = on
->
write_trace("(arg)")
;
write_trace(" ")
),
print_line_attribute(arity, arity, ArityFlag),
print_line_attribute(mode_number, mode_number, ModeNumFlag),
print_line_attribute(goal_path, goal_path, GoalPathFlag),
print_line_attribute(line_number, line_number, LineNumberFlag),
write_trace('\n'),
print_line_attribute(listvar, listvar, ListVarFlag),
!.
%------------------------------------------------------------------------------%
opium_command(
name : print_full_event,
arg_list : [],
arg_type_list : [],
abbrev : pf,
interface : hidden,
command_type : opium,
implementation : print_full_event_Op,
parameters : [indent_display, arg_undisplay,
list_display, term_display],
message :
"Prints the current trace event with all the attributes on.\
"
).
% :- pred print_full_event is det.
print_full_event_Op :-
get_parameter(attribute_display, L),
set_parameter(attribute_display,
[on, on, on, on, on, on, on, on, on, on, on, on, on, on, on, on]),
print_event_Op,
set_parameter(attribute_display, L).
%------------------------------------------------------------------------------%
opium_command(
name : print_full_displayed_attributes,
arg_list : [],
arg_type_list : [],
abbrev : _,
interface : hidden,
command_type : opium,
implementation : print_full_displayed_attributes_Op,
parameters : [indent_display, attribute_display, arg_undisplay,
list_display, term_display],
message :
"Prints the names of the attributes printed by `print_full_event/0'."
).
% :- pred print_full_displayed_attributes_Op is det.
print_full_displayed_attributes_Op :-
indent_display(IndentFlag, IndentValue, IndentDepth),
write_trace("chrono: "),
write_indent(IndentFlag, IndentValue, IndentDepth, 1),
print_line_attribute(call, call, on),
print_line_attribute(depth, depth, on),
print_line_attribute(port, port, on),
print_line_attribute(deter, deter, on),
print_line_attribute(proc_type, proc_type, on),
print_line_attribute(def_module, def_module, on),
print_line_attribute(decl_module, decl_module, on),
print_line_attribute(name, name, on),
write_trace("(arg)"),
print_line_attribute(arity, arity, on),
print_line_attribute(mode_number, mode_number, on),
print_line_attribute(goal_path, goal_path, on),
print_line_attribute(line_number, line_number, on),
write_trace('\n'),
!.
%------------------------------------------------------------------------------%
opium_command(
name : indent,
arg_list : [OnOff],
arg_type_list : [is_member([on, off])],
abbrev : _,
interface : button,
command_type : opium,
implementation : indent_Op,
parameters : [indent_display],
message :
"Sets relative indentation on/off. If a tracing process is \
on, it sets the depth at which the indentation has to start to the \
current depth. Otherwise the starting depth is 1.\
"
).
%:- pred indent(on_off).
%:- mode indent(in) is det.
indent_Op(OnOff) :-
current(depth = Depth),
indent_display(_, Value, _),
set_parameter(indent_display, [OnOff, Value, Depth]).
indent_Op(OnOff) :-
indent_display(_, Value, _),
set_parameter(indent_display, [OnOff, Value, 1]).
%------------------------------------------------------------------------------%
opium_command(
name : absolute_indent,
arg_list : [Depth],
arg_type_list : [integer],
abbrev : _,
interface : button,
command_type : opium,
implementation : absolute_indent_Op,
parameters : [indent_display],
message :
"Sets the indentation on and sets the depth at which the \
indentation has to start to `Depth'.\
"
).
%:- pred absolute_indent_Op(integer).
%:- mode absolute_indent_Op(in) is det.
absolute_indent_Op(N) :-
indent_display(_, Value, _),
set_parameter(indent_display, [on, Value, N]).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_indent,
arg_list : [IndentFlag, IndentValue, IndentDepth, CurrDepth],
implementation : write_indent_Op,
parameters : [indent_display],
message :
"Displays an indentation -- if indentation is on -- \
according to the current depth and the indentation starting depth. If \
`IndentFlag' is set to `on', it prints `N' times `IndentValue', where `N' is \
`CurrDepth - IndentDepth' if this is positive, 1 otherwise.\
"
).
%:- pred write_indent_Op(atom, atom, atom, atom).
%:- mode write_indent_Op(in, in, in, in) is det.
write_indent_Op(off, _V, _IndentDepth, _CurrDepth).
write_indent_Op(on, V, IndentDepth, CurrDepth) :-
Diff is CurrDepth - IndentDepth,
Diff >= 0,
!,
write_indentation(Diff, V).
write_indent_Op(on, _V, _IndentDepth, _CurrDepth) :-
!.
%:- pred write_indentation(integer, string).
%:- mode write_indentation(in, in) is det.
write_indentation(N, V) :-
indent_display_limit(Limit),
N > Limit,
!,
write_spaces(Limit, V).
write_indentation(N, V) :-
write_spaces(N, V).
%:- pred write_spaces(integer, string).
%:- mode write_spaces(in, in) is det.
write_spaces(0, _V) :- !.
write_spaces(M, V) :-
write_trace(V),
M1 is M-1,
write_spaces(M1, V).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_attribute,
arg_list : [AttributeName, AttributeValue],
implementation : write_attribute_Op,
parameters : [attribute_display],
message :
"Displays an attribute of the trace line. `AttributeName' is \
a member of the following list: [chrono, call, depth, port, proc_type, \
decl_module, def_module, arity, mode_number, args, deter, goal_path, \
line_number, non_arg_var]. To customize the way arguments are displayed, you \
should rather modify `write_arg/1'."
).
%:- pred write_attribute_Op(atom, atom).
%:- mode write_attribute_Op(in, in) is det.
write_attribute_Op(chrono, V) :-
printf(trace, "%3d: ", V).
write_attribute_Op(call, V) :-
write_trace(V),
write_trace(' ').
write_attribute_Op(depth, V) :-
write_trace('['),
write_trace(V),
write_trace('] ').
write_attribute_Op(port, V) :-
write_trace(V),
write_trace(' ').
write_attribute_Op(proc_type, V) :-
write_trace('('),
write_trace(V),
write_trace(') ').
write_attribute_Op(decl_module, V) :-
write_trace(V),
write_trace(': ').
write_attribute_Op(def_module, V) :-
write_trace('{'),
write_trace(V),
write_trace('} ').
write_attribute_Op(name, V) :-
write_trace(V).
write_attribute_Op(arity, V) :-
write_trace('/'),
write_trace(V).
write_attribute_Op(mode_number, V) :-
write_trace('-'),
write_trace(V).
write_attribute_Op(deter, V) :-
write_trace(V),
write_trace(' ').
write_attribute_Op(goal_path, V) :-
write_trace(' '),
write_trace(V),
write_trace(' ').
write_attribute_Op(line_number, V) :-
write_trace(' '),
write_trace(V),
write_trace(' ').
write_attribute_Op(type_arg, Type) :-
write_trace(" {"),
replace_dotdot_by_underscore_in_term(Type, Type2),
write_trace(Type2),
write_trace("}").
write_attribute_Op(listvar, List) :-
( List = [] ->
true
;
write_trace("\nNon-argument live variables:\n"),
print_list_var(List)
).
% :- pred replace_dotdot_by_underscore_in_term(term, string).
% :- mode replace_dotdot_by_underscore_in_term(in, out) is det.
replace_dotdot_by_underscore_in_term(Term, NewTerm) :-
% if Term = list : list (io : result)
% then Newterm = list__list (io__result)
(
% ex: Term = int
atom(Term),
atom_string(Term, NewTerm),
!
;
% ex: Term = list : list(int)
Term = Module : SubTerm,
atom_string(Module, ModuleStr),
replace_dotdot_by_underscore_in_term(SubTerm, NewSubTerm),
concat_string([ModuleStr, "__", NewSubTerm], NewTerm),
!
;
% ex: Term = list(io : result)
Term =.. [Functor | ListArg],
atom_string(Functor, FunctorStr),
replace_dotdot_by_underscore_in_list(ListArg, NewListArgStr),
concat_string([FunctorStr, "(", NewListArgStr, ")"],
NewTerm),
!
;
write_trace("Problem in printing the type")
).
%:- pred replace_dotdot_by_underscore_in_list(list(term), string).
%:- mode replace_dotdot_by_underscore_in_list(in, out) is det.
replace_dotdot_by_underscore_in_list([Arg], String) :-
replace_dotdot_by_underscore_in_term(Arg, String).
replace_dotdot_by_underscore_in_list([Arg | Tail], String) :-
replace_dotdot_by_underscore_in_term(Arg, NewArgStr),
replace_dotdot_by_underscore_in_list(Tail, TailStr),
concat_string([NewArgStr, " ,", TailStr], String).
%:- pred print_list_var(list(T)).
%:- mode print_list_var(in) is det.
print_list_var([]).
print_list_var([live_var(VarName, Value, Type) | Xs]) :-
printf(trace,"\t%w = %w {%w}\n", [VarName, Value, Type]),
print_list_var(Xs).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_arg_attribute,
arg_list : [Procedure, ListArg, ArgFlag, TypeFlag],
implementation : write_arg_attribute_Op,
parameters : [attribute_display],
message :
"Displays the arguments of the trace event when the \
current procedure is `Module:Name/Arity-ModeNum'. If only the nth argument \
of a procedure needs a special treatment, you should customize `write_arg/1'.\
"
).
%:- pred write_arg_attribute_Op(atom, atom, atom, atom).
%:- mode write_arg_attribute_Op(in, in, in, in) is det.
write_arg_attribute_Op(_:_/Arity-_, _, _, _) :-
Arity == 0,
!.
write_arg_attribute_Op(Proc, ListArg, ArgFlag, TypeFlag) :-
write_trace('('),
write_arguments(1, Proc, ListArg, ArgFlag, TypeFlag),
write_trace(')').
%:- pred write_arguments(integer, procedure, list(argument), flag, flag).
%:- mode write_arguments(in, in, in, in, in) is det.
write_arguments(_,_,_, off, off).
write_arguments(N, Proc, ListArg, ArgFlag, TypeFlag) :-
( retrieve_live_arg(ListArg, N, Arg, Type) ->
true
;
% This argument is not currently live.
% X Should we display the source arguments here ?
Arg = '-'
),
(
arguments_display(normal),
ArgFlag = on,
% write arguments in the normal way
write_nth_arg(Arg, N, Proc)
;
ArgFlag = on,
% write arguments in a simple way
writeq_trace(Arg)
;
% ArgFlag = off
true
),
( not(free(Type)) ->
print_line_attribute(type_arg, Type, TypeFlag)
;
true
),
NN is N + 1,
write_tail(NN, Proc, ListArg, ArgFlag, TypeFlag).
%:- pred write_tail(integer, procedure, list(argument), flag, flag).
%:- mode write_tail(in, in, in, in, in) is det.
write_tail(N, DeclModule:Name/Arity-ModeNum, ListArg, ArgFlag, TypeFlag) :-
( (N =< Arity) ->
write_comma,
write_arguments(N, DeclModule:Name/Arity-ModeNum, ListArg,
ArgFlag, TypeFlag)
;
true
).
%:- pred retrieve_live_arg(list(live_var), int, atom, atom).
%:- mode retrieve_live_arg(in, in, out, out) is semidet.
% Take a list of live arguments and an integer N and returns the Nth
% argument and its type if it is live (i.e. if it is in the list).
retrieve_live_arg([live_var(VarName, Instance, Type)|_], N, Instance, Type) :-
headvar_to_integer(VarName, N).
retrieve_live_arg([_ | Tail], N, Instance, Type) :-
retrieve_live_arg(Tail, N, Instance, Type).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_nth_arg,
arg_list : [Arg, N, Procedure],
%arg_list : [Arg, N, DeclModule:Name/Arity-ModeNum],
implementation : write_nth_arg_Op,
parameters : [arguments_display, arg_undisplay, term_display,
list_display],
message :
"Displays the nth argument of procedure `Procedure' in `DeclModule'.\
"
).
%:- pred write_nth_arg(argument, integer, procedure).
%:- mode write_nth_arg(in, in, in) is det.
write_nth_arg_Op(Arg, N, DeclModule:Name/Arity-ModeNum) :-
(
( arg_undisplay(DeclModule:Name/Arity-ModeNum, N)
; arg_undisplay(Name/Arity-ModeNum, N)
; arg_undisplay(Name/Arity, N)
)
->
/* arg not to be displayed */
write_ersatz
;
write_arg(Arg)
).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_arg,
arg_list : [Arg],
implementation : write_arg_Op,
parameters : [term_display, list_display],
message :
"Prints procedure arguments.\
"
).
%:- pred write_arg(argument).
%:- mode write_arg(in) is det.
write_arg(A) :-
write_arg_Op(A).
write_arg_Op(A) :-
var(A),
!,
write_trace(A).
write_arg_Op(A) :-
atomic(A),
!,
writeq_trace(A).
write_arg_Op(-I) :-
integer(I),
!,
write_trace('-'),
write_trace(I).
write_arg_Op([H | T]) :-
!,
write_list([H|T]).
write_arg_Op(A) :-
write_term(A).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_term,
arg_list : [Term],
implementation : write_term_Op,
parameters : [term_display],
message :
"Displays a structured term, taking into account the `term_display' parameter.\
"
).
% Variable last_op tells whether the last operator has been a
% comma or any other operator. This is taken into account by
% write_term_.../4 to ensure that (a,b,c) is printed in this way
% instead of (a, (b, c)).
:- setval(last_op, any).
%:- pred write_term(term).
%:- mode write_term(in) is det.
write_term_Op(T) :-
term_display(DType, DN),
write_term(T, DType, DN),
setval(last_op, any).
write_term(Term, _DType, _DN) :-
Term =.. [{} | [Arg]],
!,
write_trace('{'),
write_arg(Arg),
write_trace('}').
write_term(Term, DType, DN) :-
functor(Term, Op, Arity),
optype(Op, OpType),
write_term(Term, Arity, OpType, DType, DN),
!.
write_term(Term, DType, DN) :-
functor(Term, _Op, Arity),
write_term(Term, Arity, prefix, DType, DN).
write_term(Term, Arity, OpType, normal, DN) :-
write_term_normal(Term, Arity, OpType, DN).
write_term(Term, Arity, OpType, nest, DN) :-
write_term_nest(Term, Arity, OpType, DN).
write_term(Term, Arity, OpType, truncate, DN) :-
write_term_truncate(Term, Arity, OpType, DN).
/* print structured terms in normal way */
%:- pred write_term_normal(term, integer, ?, ).
%:- mode write_term_normal() is det.
write_term_normal(Term, Arity, prefix, _) :-
!,
setval(last_op, any),
Term =.. [Op | As],
write_trace(Op),
write_trace('('),
write_args_normal_int(1, Arity, As),
write_trace(')').
write_term_normal(Term, 2, infix, _) :-
Term =.. [Op | As],
Op = ',',
getval(last_op, any),
!,
setval(last_op, comma),
write_trace('('),
write_args_normal_int(1, 1, As),
write_trace(Op),
write_trace(' '),
write_args_normal_int(2, 2, As),
write_trace(')').
write_term_normal(Term, 2, infix, _) :-
Term =.. [Op | As],
Op = ',',
!,
write_args_normal_int(1, 1, As),
write_trace(Op),
write_trace(' '),
write_args_normal_int(2, 2, As).
write_term_normal(Term, 2, infix, _) :-
!,
setval(last_op, any),
Term =.. [Op | As],
write_args_normal_int(1, 1, As),
write_trace(' '),
write_trace(Op),
write_trace(' '),
write_args_normal_int(2, 2, As).
write_term_normal(Term, Arity, postfix, _) :-
setval(last_op, any),
Term =.. [Op | As],
write_trace('('),
write_args_normal_int(1, Arity, As),
write_trace(')'),
write_trace(Op).
% XXX ???: fourth argument of write_term_normal is always '_'.
% Mireille wrote that code, I should ask her what she means doing so.
write_args_normal_int(1, To, Args) :-
!,
write_n_args_normal(To, Args).
write_args_normal_int(From, To, [_As | Args]) :-
NF is From - 1,
NT is To - 1,
write_args_normal_int(NF, NT, Args).
write_n_args_normal(1, [Arg|_]) :-
!,
write_arg_normal(Arg).
write_n_args_normal(N, [Arg|As]) :-
write_arg_normal(Arg),
write_trace(', '),
N0 is N - 1,
write_n_args_normal(N0, As).
write_arg_normal(A) :-
var(A),
!,
write_trace(A).
write_arg_normal(A) :-
atomic(A),
!,
writeq_trace(A).
write_arg_normal(-I) :-
integer(I),
!,
write_trace('-'),
write_trace(I).
write_arg_normal([H | T]) :-
!,
write_list([H|T]).
write_arg_normal(A) :-
write_term(A).
/* print structured terms with limitation to nesting */
write_term_nest(_, _, _, 0) :-
!,
setval(last_op, any),
write_ersatz.
write_term_nest(Term, Arity, prefix, L) :-
!,
setval(last_op, any),
Term =.. [Op | As],
write_trace(Op),
write_trace('('),
write_args_nest_int(1, Arity, As, L),
write_trace(')').
write_term_nest(Term, 2, infix, L) :-
Term =.. [Op | As],
Op = ',',
getval(last_op, any),
!,
setval(last_op, comma),
write_trace('('),
write_args_nest_int(1, 1, As, L),
write_trace(Op),
write_trace(' '),
write_args_nest_int(2, 2, As, L),
write_trace(')').
write_term_nest(Term, 2, infix, L) :-
Term =.. [Op | As],
Op = ',',
!,
write_args_nest_int(1, 1, As, L),
write_trace(Op),
write_trace(' '),
write_args_nest_int(2, 2, As, L).
write_term_nest(Term, 2, infix, L) :-
!,
setval(last_op, any),
Term =.. [Op | As],
write_args_nest_int(1, 1, As, L),
write_trace(' '),
write_trace(Op),
write_trace(' '),
write_args_nest_int(2, 2, As, L).
write_term_nest(Term, Arity, postfix, L) :-
!,
setval(last_op, any),
Term =.. [Op | As],
write_trace('('),
write_args_nest_int(1, Arity, As, L),
write_trace(')'),
write_trace(Op).
write_args_nest_int(1, To, Args, L) :-
!,
write_n_args_nest(To, Args, L).
write_args_nest_int(From, To, [_As | Args], L) :-
NF is From - 1,
NT is To - 1,
write_args_nest_int(NF, NT, Args, L).
write_n_args_nest(1, [Arg|_], L) :-
!,
write_arg_nest(Arg, L).
write_n_args_nest(N, [Arg|As], L) :-
write_arg_nest(Arg, L),
write_trace(', '),
N0 is N - 1,
write_n_args_nest(N0, As, L).
write_arg_nest(A, _) :-
var(A),
!,
write_trace(A).
write_arg_nest(A, _) :-
atomic(A),
!,
writeq_trace(A).
write_arg_nest(-I, _) :-
integer(I),
!,
write_trace('-'),
write_trace(I).
write_arg_nest([H | T], _N) :-
!,
%N0 is N - 1,
write_list([H|T]).
write_arg_nest(A, N) :-
N0 is N - 1,
write_term(A, nest, N0).
/* print structured terms in a truncated way */
write_term_truncate(_, _, _, 0) :-
!,
setval(last_op, any),
write_ersatz.
write_term_truncate(Term, Arity, prefix, L) :-
!,
setval(last_op, any),
Term =.. [Op | As],
write_trace(Op),
write_trace('('),
write_args_truncate_int(1, Arity, As, L),
write_trace(')').
write_term_truncate(Term, 2, infix, L) :-
Term =.. [Op | As],
Op = ',',
getval(last_op, any),
!,
setval(last_op, comma),
write_trace('('),
write_args_truncate_int(1, 1, As, L),
write_trace(Op),
write_trace(' '),
write_args_truncate_int(2, 2, As, L),
write_trace(')').
write_term_truncate(Term, 2, infix, L) :-
Term =.. [Op | As],
Op = ',',
!,
write_args_truncate_int(1, 1, As, L),
write_trace(Op),
write_trace(' '),
write_args_truncate_int(2, 2, As, L).
write_term_truncate(Term, 2, infix, L) :-
!,
setval(last_op, any),
Term =.. [Op | As],
write_args_truncate_int(1, 1, As, L),
write_trace(' '),
write_trace(Op),
write_trace(' '),
write_args_truncate_int(2, 2, As, L).
write_term_truncate(Term, Arity, postfix, L) :-
setval(last_op, any),
Term =.. [Op | As],
write_trace('('),
write_args_truncate_int(1, Arity, As, L),
write_trace(')'),
write_trace(Op).
write_args_truncate_int(1, To, Args, L) :-
!,
write_n_args_truncate(To, Args, L).
write_args_truncate_int(From, To, [_As | Args], L) :-
NF is From - 1,
NT is To - 1,
NL is L - 1,
write_args_truncate_int(NF, NT, Args, NL).
write_n_args_truncate(N, _Args, L) :-
N > L,
!,
write_ersatz.
write_n_args_truncate(_N, [Arg|_], L) :-
!,
write_arg_truncate(Arg, L).
write_n_args_truncate(N, [Arg|As], L) :-
write_arg_truncate(Arg, L),
write_trace(', '),
N0 is N - 1,
write_n_args_truncate(N0, As, L).
write_arg_truncate(A, _) :-
var(A),
!,
write_trace(A).
write_arg_truncate(A, _) :-
atomic(A),
!,
writeq_trace(A).
write_arg_truncate(-I, _) :-
integer(I),
!,
write_trace('-'),
write_trace(I).
write_arg_truncate([H | T], _L) :-
!,
write_list([H|T]).
write_arg_truncate(A, L) :-
write_term(A, truncate, L).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_list,
arg_list : [List],
implementation : write_list_Op,
parameters : [list_display],
message :
"Displays a list, taking into account the `list_display' parameter.\
"
).
%:- pred write_list_Op(list(T)).
%:- mode write_list_Op(in) is det.
write_list_Op(L) :-
list_display(Type, N),
write_list_l(L, Type, N).
write_list_l(L, normal, _) :-
write_normal_list_l(L).
write_list_l(L, nest, N) :-
write_nest_list_l(L, 1, N).
write_list_l(L, truncate, N) :-
write_truncate_list_l(L, N).
/* display lists in the normal way */
write_normal_list_l(L) :-
write_trace('['),
write_normal_elements_l(L),
write_trace(']').
write_normal_elements_l([H|T]) :-
write_normal_elements_i(H),
write_normal_tail(T),
!.
write_normal_elements_l(X) :-
/* if list structure isn't proper */
writeq_trace(X).
write_normal_elements_i(V) :-
var(V),
!,
write_trace(V).
write_normal_elements_i(A) :-
atomic(A),
!,
writeq_trace(A).
write_normal_elements_i(-I) :-
integer(I),
!,
write_trace('-'),
write_trace(I).
write_normal_elements_i([H | T]) :-
!,
write_normal_list_l([H | T]).
write_normal_elements_i(A) :-
write_term(A).
write_normal_tail(T) :-
/* otherwise cyclic structures can be created */
var(T),
!,
write_trace('|'),
write_trace(T).
write_normal_tail(T) :-
T == [],
!.
write_normal_tail([TH | TT]) :-
/* tail is a proper list */
!,
write_comma,
write_normal_elements_l([TH | TT]).
write_normal_tail(T) :-
write_trace('|'),
write_trace(T).
/* display of lists with limit to nesting */
write_nest_list_l(L, N, Nest) :-
write_trace('['),
write_nest_list_els(L, N, Nest),
write_trace(']').
write_nest_list_els(_L, N, Nest) :-
N > Nest,
!,
write_ersatz.
write_nest_list_els(L, N, Nest) :-
write_nest_elements_l(L, N, Nest).
write_nest_elements_l([H|T], N, Nest) :-
write_nest_elements_i(H, N, Nest),
write_nest_tail(T, N, Nest),
!.
write_nest_elements_l(X, _N, _Nest) :-
/* if list structure isn't proper */
writeq_trace(X).
write_nest_elements_i(V, _, _) :-
var(V),
!,
write_trace(V).
write_nest_elements_i(A, _, _) :-
atomic(A),
!,
writeq_trace(A).
write_nest_elements_i(-I, _, _) :-
integer(I),
!,
write_trace('-'),
write_trace(I).
write_nest_elements_i([H | T], N, Nest) :-
!,
N1 is N + 1,
write_nest_list_l([H | T], N1, Nest).
write_nest_elements_i(A, _, _) :-
write_term(A).
write_nest_tail(T, _, _) :-
/* otherwise cyclic structures can be created */
var(T),
!,
write_trace('|'),
write_trace(T).
write_nest_tail(T, _N, _Nest) :-
T == [],
!.
write_nest_tail([TH | TT], N, Nest) :-
/* tail is a proper list */
!,
write_comma,
write_nest_elements_l([TH | TT], N, Nest).
write_nest_tail(T, _N, _Nest) :-
write_trace('|'),
write_trace(T).
/* truncated display of lists ie. only the Nth first elements */
write_truncate_list_l(L, Trunc) :-
write_trace('['),
write_truncate_elements_l(L, 0, Trunc),
write_trace(']').
write_truncate_elements_l([_H|_T], N, Trunc) :-
N >= Trunc,
!,
write_ersatz.
write_truncate_elements_l([H|T], N, Trunc) :-
write_truncate_elements_i(H, Trunc),
write_truncate_tail(T, N, Trunc).
write_truncate_elements_l(X, _N, _Trunc) :-
% if list structure isn't proper
writeq_trace(X).
write_truncate_elements_i(V, _) :-
var(V),
!,
write_trace(V).
write_truncate_elements_i(A, _) :-
atomic(A),
!,
writeq_trace(A).
write_truncate_elements_i(-I, _) :-
integer(I),
!,
write_trace('-'),
write_trace(I).
write_truncate_elements_i([H|T], Trunc) :-
!,
write_truncate_list_l([H|T], Trunc).
write_truncate_elements_i(A, _) :-
write_term(A).
write_truncate_tail(T, _, _) :-
/* otherwise cyclic structures can be created */
var(T),
!,
write_trace('|'),
write_trace(T).
write_truncate_tail(T, _N, _Trunc) :-
T==[],
!.
write_truncate_tail([TH | TT], N, Trunc) :-
/* tail is a proper list */
!,
write_comma,
N1 is N+1,
write_truncate_elements_l([TH | TT], N1, Trunc).
write_truncate_tail(T, _N, _Trunc) :-
write_trace('|'),
write_trace(T).
%------------------------------------------------------------------------------%
opium_procedure(
name : write_ersatz,
arg_list : [],
implementation : write_ersatz_Op,
parameters : [],
message :
"Writes `...' as a replacement for the hidden parts of the arguments.\
"
).
%:- pred write_ersatz is det.
write_ersatz_Op :-
write_trace('...').
%------------------------------------------------------------------------------%
opium_procedure(
name : write_comma,
arg_list : [],
implementation : write_comma_Op,
parameters : [],
message :
"Writes `, '."
).
write_comma_Op :-
write_trace(', ').
%------------------------------------------------------------------------------%
opium_procedure(
name : write_trace,
arg_list : [X],
implementation : write_trace_Op,
parameters : [],
message :
'Prints its argument on the trace window.\
'
).
%:- pred write_trace(atom).
%:- mode write_trace(in) is det.
write_trace_Op(X) :-
write(trace, X),
flush(trace).
%------------------------------------------------------------------------------%
%:- pred writeq_trace(atom).
%:- mode writeq_trace(in) is det.
writeq_trace(X) :-
printf(trace, "%Qw", [X]).
%------------------------------------------------------------------------------%
opium_parameter(
name : attribute_display,
arg_list : [Chrono, Call, Port, Depth, Deter, PredOrFunc,
DeclModule, DefModule, Name, Arity,
ModeNumber, ListArg, ListNonArgVar, Type,
GoalPath, LineNumber],
arg_type_list : [is_member([on,off]), is_member([on,off]),
is_member([on,off]), is_member([on,off]),
is_member([on,off]), is_member([on,off]),
is_member([on,off]), is_member([on,off]),
is_member([on,off]), is_member([on,off]),
is_member([on,off]), is_member([on,off]),
is_member([on,off]), is_member([on,off]),
is_member([on,off]), is_member([on,off])],
parameter_type : single,
default : [on, on, on, on, off, off, off, off, on, off, off,
on, off, off, on, on],
commands : [print_event],
message :
"Parameter which contains the flags for the selective display of attributes. \
If the value of one argument is \"on\" then the corresponding attribute is \
displayed.\
"
).
%------------------------------------------------------------------------------%
opium_parameter(
name : arguments_display,
arg_list : [Type],
arg_type_list : [is_member([normal, simple])],
parameter_type : single,
default : [normal],
commands : [write_arg],
message :
"Specifies how arguments shall be displayed. If `Type' is set to `simple', \
then arguments are displayed without taking the `list_display' and \
`term_display' parameters into account.\
"
).
%------------------------------------------------------------------------------%
opium_parameter(
name : list_display,
arg_list : [Type, Range],
arg_type_list : [is_member([normal, nest, truncate]), integer],
parameter_type : single,
default : [normal, 0],
commands : [select_list_display, write_list],
message :
"Specifies how lists shall be displayed. If `Type' is set to `normal', \
lists are displayed in the standard Prolog way. If `Type' is set to `nest', \
the nested lists are displayed only till level `Range' (included). If `Type' is \
set to `truncate', only the first `Range' elements of the lists are displayed.\
"
).
%------------------------------------------------------------------------------%
opium_parameter(
name : term_display,
arg_list : [Type, Range],
arg_type_list : [is_member([normal, nest, truncate]), integer],
parameter_type : single,
default : [normal, 0],
commands : [write_term],
message :
"Specifies how structured terms shall be displayed. If `Type' is set to \
`normal', terms are displayed in the standard Prolog way. If `Type' is \
set to `nest', the nested terms are displayed only till level `Range' \
(included). If `Type' is set to `truncate', only the first `Range' elements \
of the term are displayed.\
"
).
%------------------------------------------------------------------------------%
opium_parameter(
name : indent_display,
arg_list : [OnOff, IndentationValue, Depth],
arg_type_list : [is_member([on, off]), atomic, integer],
parameter_type : single,
default : [on, ' ', 1],
commands : [print_event, write_indent],
message :
"Specifies whether indentation is `on' or `off', what has to be \
printed as indentation value, and at which depth the indentation has to be \
started.\
"
).
%------------------------------------------------------------------------------%
opium_parameter(
name : indent_display_limit,
arg_list : [IndentLimit],
arg_type_list : [integer],
parameter_type : single,
default : [30],
commands : [write_indent],
message :
"Specifies up to which depth the trace events shall be indented.\
"
).
%------------------------------------------------------------------------------%
opium_parameter(
name : arg_undisplay,
arg_list : [Name, ArgNo],
arg_type_list : [is_proc, integer],
parameter_type : multiple,
default : nodefault,
commands : [write_arg],
message :
"Specifies which arguments of which predicates have to be not \
displayed. There must be one `arg_undisplay' clause for each argument which \
shall not be displayed.\
"
).
/*
* optype/2
*/
optype(Op, OpType) :-
/* standard Sepia operators */
current_op(_P, A, Op),
get_optype(A, OpType).
get_optype(yfx, infix) :- !.
get_optype(xfy, infix) :- !.
get_optype(xfx, infix) :- !.
get_optype(xf, postfix) :- !.
get_optype(yf, postfix) :- !.
get_optype(fx, prefix) :- !.
get_optype(fy, prefix) :- !.
%------------------------------------------------------------------------------%
opium_procedure(
name : read_input,
arg_list : [Input],
implementation : read_input_Op,
parameters : [],
message :
"Reads an input from within the current input stream of Morphine.\
"
).
/* read in both cases from the input stream
*/
read_input_Op(X) :-
read(input, X).
%------------------------------------------------------------------------------%
opium_command(
name : toggle,
arg_list : [AttributeName],
arg_type_list : [atom],
abbrev : _,
interface : hidden,
command_type : opium,
implementation : toggle_Op,
parameters : [],
message :
"Toggles attribute display of `print_event/1' command. \n\
For example, if attribute `decl_module' is off, you can type \
`toggle(decl_module)' to switch it on. You can list all the attributes \
you can toggle thanks to `list_attribute_aliases/0'.\
"
).
toggle_Op(Keyword) :-
get_parameter(attribute_display, ListDisplay), !,
update_list_display(Keyword, ListDisplay, NewListDisplay),
set_parameter(attribute_display, NewListDisplay).
update_list_display(Keyword, ListDisplay, NewListDisplay) :-
(
is_alias_for(chrono, Keyword),
ListDisplay = [S, O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,O12,O13,
O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [NewS, O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(call, Keyword),
ListDisplay = [O1, S,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1, NewS,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(port, Keyword),
ListDisplay = [O1,O2, S,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2, NewS,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13, O14,O15,O16],
!
;
is_alias_for(depth, Keyword),
ListDisplay = [O1,O2,O3, S,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3, NewS,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(det, Keyword),
ListDisplay = [O1,O2,O3,O4,S,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,NewS,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(proc_type, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,S,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,NewS,O7,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(decl_module, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,S,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,NewS,O8,O9,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(def_module, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,O7,S,O9,O10,O11,
O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,NewS,O9,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(name, Keyword),
ListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,S,O10,O11,O12,
O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,NewS,O10,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(arity, Keyword),
ListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,O9,S,O11,O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,O9,NewS,O11,
O12,O13,O14,O15,O16],
!
;
is_alias_for(mode_number, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,S,O12,O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,NewS,
O12,O13,O14,O15,O16],
!
;
is_alias_for(args, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,S,
O13,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,
O11,NewS,O13,O14,O15,O16],
!
;
is_alias_for(local_vars, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,S,O14,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,NewS,O14,O15,O16],
!
;
is_alias_for(arg_types, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,O12,
O13,S,O15,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13,NewS,O15,O16],
!
;
is_alias_for(goal_path, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,O12,
O13,O14,S,O16],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,NewS,O16],
!
;
is_alias_for(line_number, Keyword),
ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,O12,
O13,O14,O15,S],
( S = off ->
NewS = on
;
NewS = off
),
NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
O12,O13,O14,O15,NewS]
).
%------------------------------------------------------------------------------%
opium_procedure(
name : display_stack,
arg_list : [Stack],
implementation : display_stack_Op,
parameters : [],
message :
"Displays the ancestors stack."
).
display_stack_Op([level(Level) | Tail]) :-
printf(trace, "\nLevel %w: ", Level),
display_stack_Op(Tail).
display_stack_Op([detail(Chrono, Call, Depth) | Tail]) :-
printf(trace, "(chrono=%w, call=%w, depth=%w) ", [Chrono, Call, Depth]),
display_stack_Op(Tail).
display_stack_Op([pred | Tail]) :-
printf(trace, "pred ", []),
display_stack_Op(Tail).
display_stack_Op([func | Tail]) :-
printf(trace, "func ", []),
display_stack_Op(Tail).
display_stack_Op([proc(Proc) | Tail]) :-
printf(trace, "%w ", Proc),
display_stack_Op(Tail).
display_stack_Op([proc(M1,M2,N,A,MN) | Tail]) :-
printf(trace, "%w for w:%w/%w-%w ", [M1,M2,N,A,MN]),
display_stack_Op(Tail).
display_stack_Op([proc(M,N,A,MN) | Tail]) :-
printf(trace, "%w:%w/%w-%w ", [M,N,A,MN]),
display_stack_Op(Tail).
display_stack_Op([det(Det) | Tail]) :-
printf(trace, "(%w) ", Det),
display_stack_Op(Tail).
display_stack_Op([def_module(Module) | Tail]) :-
printf(trace, "{definition module=%w} ", Module),
display_stack_Op(Tail).
display_stack_Op([]) :-
printf(trace, "\n", []),
flush(trace).
%------------------------------------------------------------------------------%
opium_procedure(
name : display_list_var_names,
arg_list : [ListVarNames],
implementation : display_list_var_names_Op,
parameters : [],
message :
"Displays the names of the currently live variables given by \
`current_live_var_names_and_types/1'.\
"
).
display_list_var_names_Op([]).
display_list_var_names_Op([ live_var_names_and_types(Name, Type) | Tail]) :-
printf(user, " %w {%w}\n", [Name, Type]),
display_list_var_names_Op(Tail).