[m-dev.] Opium-M [2/5]
Erwan Jahier
Erwan.Jahier at irisa.fr
Tue Oct 26 23:46:27 AEST 1999
Index: extras/opium_m/source/current_slots_M.op
===================================================================
RCS file: current_slots_M.op
diff -N current_slots_M.op
--- /dev/null Wed May 28 10:49:58 1997
+++ current_slots_M.op Tue Oct 26 23:26:31 1999
@@ -0,0 +1,686 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier <jahier at irisa.fr>
+%
+% This file implements all the predicates that deal with non-argument
+% attributes retrieval.
+
+
+% The same declaration has been done in forward_move.op
+:- op(900, xfy, and).
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : current,
+ arg_list : [AttributesConjunctOrList],
+ arg_type_list : [is_list_or_conj_of_attributes_current],
+ abbrev : curr,
+ interface : button,
+ command_type : opium,
+ implementation : current_Op,
+ parameters : [],
+ message :
+"Gets or checks the values of the event attributes specified in \
+AttributesConjunctOrList. AttributesConjunctOrList is a conjunction or a list \
+of terms of the form attribute = Value. \n\
+If Value is a free variable, it is unified with the current value of the \
+attribute. \
+If Value is a ground term, the current value of the attribute is retrieved and \
+checked against Value.\n\
+\n\
+The different attributes for current/1 are : \n\
+ \n\
+chrono: \n\
+ chronological event number of the event, \n\
+call: \n\
+ call event number of the event, \n\
+depth: \n\
+ depth in the proof three (number of ancestors - 1) of the event, \n\
+port: \n\
+ type of the event, \n\
+proc_type: \n\
+ tells if the current procedure is a predicate or a function, \n\
+decl_module: \n\
+ module name where the procedure is declared, \n\
+def_module: \n\
+ module name where the procedure is defined, \n\
+name: \n\
+ procedure name, \n\
+arity: \n\
+ procedure arity, \n\
+mode_number: \n\
+ procedure mode number, \n\
+proc: \n\
+ procedure ([proc_type->][decl_module:](name[/arity][-mode_number]) where \
+only the attribute name is mandatory), \n\
+det: \n\
+ procedure determinism, \n\
+goal_path: \n\
+ goal path of the call of the procedure, \n\
+args: \n\
+ list of procedure arguments (*), \n\
+arg_names: \n\
+ list of procedure argument names, \n\
+arg_types: \n\
+ list of procedure argument types, \n\
+vars: \n\
+ list of the currently live variables, \n\
+var_names_and_types: \n\
+ list of the currently live variable names and types, \n\
+local_vars: \n\
+ list of the currently non-argument local live variables. \n\
+stack: \n\
+ list of the stack element. \n\
+\n\
+For example, \
+current(chrono = Chrono and name = Name) (or current([chrono = Chrono, \
+name = Name])) will unify Chrono with the chronological \
+event number and Name with the procedure name of the current event. \
+current(depth = 3) will succeed iff the depth of the current event is 3. \
+current(args = [Arg1, -, -]) will unify Arg1 with the first argument of the \
+current procedure if is live. \n\
+ \n\
+(*) non lived arguments are unified with '-' and if you do not want to retrieve \
+all the arguments (because one of them is very big for example), \
+you can use the atom '-': for example, current(arg = [X, -, -]) will only \
+retrieve \
+the first argument. Note that current(arg = [X, _, _] will have the same \
+behaviour, but arguments will be retrieved through the socket."
+ ).
+
+current_Op(ListOrConj) :-
+ getval(state_of_opium, running),
+ (
+ is_list(ListOrConj),
+ current_list(ListOrConj),
+ !
+ ;
+ conj_to_list(ListOrConj, List),
+ current_list(List)
+ ),
+ !.
+
+current_list([H|T]) :-
+ % We retrieve attributes one by one which is quite ineffective only if we
+ % have a lot of attributes to retrieve. In that case, it is better to
+ % use current_attributes/13.
+ current_one(H),
+ current_list(T),
+ !.
+current_list([]).
+
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : current_attributes,
+ arg_list : [Chrono, Call, Depth, Port, PredOrFunc, DeclModule,
+ DefModule, Name, Arity, ModeNumber, Det,
+ GoalPath /* , LineNumber */],
+ arg_type_list : [is_integer_or_var, is_integer_or_var,
+ is_integer_or_var, is_port_or_var,
+ is_atom_or_var, is_atom_or_var,
+ is_atom_or_var, is_atom_or_var,
+ is_integer_or_var, is_integer_or_var,
+ is_det_marker_or_var, is_goal_path_or_var
+ /* , is_integer_or_var */],
+ abbrev : _,
+ implementation : current_attributes_Op,
+ message :
+"current_attributes/12 retrieves all the event attributes except the argument \
+attributes."
+ ).
+
+% :- pred current_attributes(atom, ..., atom).
+% :- mode current_attributes(?, ..., ?) is nondet.
+ % Determinism is coded by an integer so we need to wrap the
+ % the call of current_attributes with determinism conversion.
+current_attributes_Op(Chrono, Call, Depth, Port, PredOrFunc, DeclModule,
+ DefModule, Name, Arity, ModeNumber, Det, GoalPath /* ,
+ LineNumber */) :-
+
+ send_message_to_socket(current_slots),
+ read_message_from_socket(Response),
+ (
+ Response = current_slots_comp(RetrievedChrono, RetrievedCall,
+ RetrievedDepth, RetrievedPort,
+ RetrievedTypeNameStr, RetrievedTypeModuleStr,
+ RetrievedDefModuleStr, RetrievedNameStr,
+ RetrievedArity, RetrievedModeNumber,
+ RetrievedDeterminism, RetrievedGoalPath
+ /*, RetrievedLineNumber */ )
+ ->
+ write("The current event is compiler generated event, "),
+ write("they are not handled yet in Opium-M.\n"),
+ fail
+ % XXX
+ % Anyway, this should never arrive here as long as we
+ % do not send any forward_move_comp requests.
+ ;
+ Response = current_slots_user(RetrievedChrono, RetrievedCall,
+ RetrievedDepth, RetrievedPort,
+ RetrievedPredOrFunc, RetrievedDeclModuleStr,
+ RetrievedDefModuleStr, RetrievedNameStr,
+ RetrievedArity, RetrievedModeNumber,
+ RetrievedDeterminism, RetrievedGoalPath
+ /*, RetrievedLineNumber */ )
+ ->
+ % for 'decl_module', 'def_module' and 'name' attributes,
+ % Mercury sends string whereas we prefer to manipulate
+ % Prolog atoms; so we convert them.
+ atom_string(RetrievedDeclModule,
+ RetrievedDeclModuleStr),
+ atom_string(RetrievedDefModule, RetrievedDefModuleStr),
+ atom_string(RetrievedName, RetrievedNameStr),
+
+ % for 'det' attributes, Mercury process sends an integer that
+ % codes the determinism.
+ ( not(Det == '-') ->
+ convert_integer_determinism_exact(
+ RetrievedDeterminism, UncodedDet)
+ ;
+ % No use to pay the cost of the conversion if it
+ % needed
+ true
+ ),
+
+ % for 'port' attribute, the name the Mercury process sends is
+ % not the ones we use at the Opium-M side.
+ ( not(Port == '-') ->
+ convert_mercury_port_opium_port_exact(
+ RetrievedPort, OpiumPort)
+ ;
+ true
+ ),
+
+ % for 'goal_path' attribute, Mercury sends a string whereas
+ % we want a list.
+ ( not(GoalPath == '-') ->
+ convert_goal_path_string_to_list(RetrievedGoalPath,
+ GoalPathList)
+ ;
+ true
+ ),
+
+ % For each argument of current_attributes, if it is
+ % * '-', we do nothing.
+ % * a variable, it is unified with the retrieved value.
+ % * an instantiated term, we check if the retrieved value
+ % is the same.
+ unify_attribute(RetrievedChrono, Chrono),
+ unify_attribute(RetrievedCall, Call),
+ unify_attribute(RetrievedDepth, Depth),
+ unify_attribute(OpiumPort, Port),
+ unify_attribute(RetrievedPredOrFunc, PredOrFunc),
+ unify_attribute(RetrievedDeclModule, DeclModule),
+ unify_attribute(RetrievedDefModule, DefModule),
+ unify_attribute(RetrievedName, Name),
+ unify_attribute(RetrievedArity, Arity),
+ unify_attribute(RetrievedModeNumber, ModeNumber),
+ unify_attribute(UncodedDet, Det),
+ unify_attribute(GoalPathList, GoalPath)
+ /*, unify_attribute(RetrievedLineNumber, LineNumber) */
+ ;
+ % I should uncomment that when [EOT] is fix.
+ % Response = eot
+ %->
+ % write(stderr, "eot: you can't retrieve any attributes"),
+ % fail
+ %;
+ Response = error(ErrorMessage)
+ ->
+ write(stderr, "Error in current_attributes/11 (current_slots.op)\n"),
+ write(stderr, " An error occured in the Mercury process: "),
+ write(stderr, ErrorMessage),
+ opium_abort
+ ;
+ write(stderr, "Error in current_attributes/11 (current_slots.op)\n"),
+ write(stderr, "The Mercury process sends: "),
+ write(Response),
+ write(stderr, "\n"),
+ opium_abort
+ ).
+
+
+% :- pred unify_attribute(atom, atom).
+% :- mode unify_attribute(in, out) is det.
+% :- mode unify_attribute(in, in) is semidet.
+ % If Attribute is free, binds it with RetrievedAttribute.
+ % If Attribute is '-', just succeeds.
+ % If Attribute is bound and different from '-', check if Attribute and
+ % RetrievedAttribute unifies.
+unify_attribute(RetrievedAttribute, Attribute) :-
+ (
+ free(Attribute),
+ Attribute = RetrievedAttribute,
+ !
+ ;
+ Attribute = '-',
+ !
+ ;
+ Attribute = RetrievedAttribute
+ ).
+
+
+%:- pred convert_goal_path_string_to_list(string, list(T)).
+%:- mode convert_goal_path_string_to_list(in, out) is det.
+convert_goal_path_string_to_list("", []) :- !.
+convert_goal_path_string_to_list(String, [X|Xs]) :-
+ find_next_point_dot(String, N),
+ N1 is N - 1,
+ substring(String, 1, N1, Str),
+ append_strings(Str, ";", S1),
+ append_strings(S1, NewString, String),
+ atom_string(X, Str),
+ convert_goal_path_string_to_list(NewString, Xs).
+
+% find the position of the first point dot in the string String.
+find_next_point_dot(String, Position) :-
+ generate(Position),
+ substring(String, Position, 1, ";"),
+ !.
+
+generate(N) :-
+ generate(1, N).
+generate(N, M) :-
+ (
+ M = N
+ ;
+ T is N + 1,
+ generate(T, M)
+ ).
+
+
+%------------------------------------------------------------------------------%
+current_one(Attribute = X) :-
+ is_alias_for(stack, Attribute),
+ stack1(X),
+ !.
+
+current_one(Attribute = X) :-
+ is_alias_for(args, Attribute),
+ current_arg(X),
+ !.
+
+current_one(Attribute = X) :-
+ is_alias_for(arg_names, Attribute),
+ current_arg_names(X),
+ !.
+
+current_one(Attribute = X) :-
+ is_alias_for(arg_types, Attribute),
+ current_arg_types(X),
+ !.
+
+current_one(Attribute = Z) :-
+ is_alias_for(vars, Attribute),
+ current_vars(X, Y),
+ append(X, Y, Z),
+ !.
+
+current_one(Attribute = LVN) :-
+ is_alias_for(var_names_and_types, Attribute),
+ current_live_var_names_and_types(LVN),
+ !.
+
+current_one(Attribute = OtherVar) :-
+ is_alias_for(local_vars, Attribute),
+ current_vars(_, OtherVar),
+ !.
+
+current_one(Attribute = Chrono) :-
+ is_alias_for(chrono, Attribute),
+ current_attributes(Chrono, -, -, -, -, -, -, -, -, -, -, - /*, - */),
+ !.
+
+current_one(Attribute = Call) :-
+ is_alias_for(call, Attribute),
+ current_attributes(-, Call, -, -, -, -, -, -, -, -, -, - /*, - */),
+ !.
+
+current_one(Attribute = Depth) :-
+ is_alias_for(depth, Attribute),
+ current_attributes(-, -, Depth, -, -, -, -, -, -, -, -, - /*, - */),
+ !.
+
+current_one(Attribute = Port) :-
+ is_alias_for(port, Attribute),
+ current_attributes(-, -, -, Port, -, -, -, -, -, -, -, - /*, - */),
+ !.
+
+current_one(Attribute = PredOrFunc) :-
+ is_alias_for(proc_type, Attribute),
+ current_attributes(-, -, -, -, PredOrFunc, -, -, -, -, -, -, -
+ /*, - */),
+ !.
+
+current_one(Attribute = DeclModule) :-
+ is_alias_for(decl_module, Attribute),
+ current_attributes(-, -, -, -, -, DeclModule, -, -, -, -, -, -
+ /*, - */),
+ !.
+
+current_one(Attribute = DefModule) :-
+ is_alias_for(def_module, Attribute),
+ current_attributes(-, -, -, -, -, -, DefModule, -, -, -, -, - /*, - */),
+ !.
+
+current_one(Attribute = Name) :-
+ is_alias_for(name, Attribute),
+ current_attributes(-, -, -, -, -, -, -, Name, -, -, -, - /*, - */),
+ !.
+
+current_one(Attribute = Arity) :-
+ is_alias_for(arity, Attribute),
+ current_attributes(-, -, -, -, -, -, -, -, Arity, -, -, - /*, - */),
+ !.
+
+current_one(Attribute = ModeNumber) :-
+ is_alias_for(mode_number, Attribute),
+ current_attributes(-, -, -, -, -, -, -, -, -, ModeNumber, -, -
+ /*, - */),
+ !.
+
+current_one(Attribute = Proc) :-
+ is_alias_for(proc, Attribute),
+ (
+ free(Proc),
+ current_attributes(-,-,-,-, PT, M, -, N, A, MN,-,- /*,-*/),
+ Proc = (PT->(M:(N/A-MN))),
+ !
+ ;
+ Proc = N,
+ is_atom_or_var(N),
+ current_attributes(-,-,-,-, -, -, -, N, -, -,-,- /*,-*/),!
+ ;
+ Proc = (PT->N),
+ is_atom_or_var(N),
+ is_atom_or_var(PT),
+ current_attributes(-,-,-,-, PT, -, -, N, -, -,-,- /*,-*/),
+ !
+ ;
+ Proc = M:N,
+ current_attributes(-,-,-,-, -, M, -, N, -, -,-,- /*,-*/),
+ !
+ ;
+ Proc = N/A,
+ current_attributes(-,-,-,-, -, -, -, N, A,-,-,- /*,-*/),
+ !
+ ;
+ Proc = N-MN,
+ is_atom_or_var(N),
+ is_atom_or_var(MN),
+ current_attributes(-,-,-,-, -, -, -, N,-, MN,-,- /*,-*/),
+ !
+ ;
+ Proc = (N/A-MN),
+ is_atom_or_var(N),
+ is_atom_or_var(A),
+ is_atom_or_var(MN),
+ current_attributes(-,-,-,-, -, -, -, N, A, MN,-,- /*,-*/),
+ !
+ ;
+ Proc = M:(N-MN),
+ current_attributes(-,-,-,-, -, M, -, N, -, MN,-,- /*,-*/),
+ !
+ ;
+ Proc = M:(N/A),
+ current_attributes(-,-,-,-, -, M, -, N, A, -,-,- /*,-*/),
+ !
+ ;
+ Proc = (PT->(N-MN)),
+ current_attributes(-,-,-,-, PT, -, -, N, -, MN,-,- /*,-*/),
+ !
+ ;
+ Proc = (PT->(N/A)),
+ current_attributes(-,-,-,-, PT, -, -, N, A, -,-,- /*,-*/),
+ !
+ ;
+ Proc = (PT->M:N),
+ current_attributes(-,-,-,-, PT, M, -, N, -, -,-,- /*,-*/),
+ !
+ ;
+ Proc = M:(N/A-MN),
+ current_attributes(-,-,-,-, -, M, -, N, A, MN,-,- /*,-*/),
+ !
+ ;
+ Proc = (PT->(N/A-MN)),
+ current_attributes(-,-,-,-, PT, -, -, N, A, MN,-,- /*,-*/),
+ !
+ ;
+ Proc = (PT->M:(N-MN)),
+ current_attributes(-,-,-,-, PT, M, -, N, -, MN,-,- /*,-*/),
+ !
+ ;
+ Proc = (PT->M:(N/A)),
+ current_attributes(-,-,-,-, PT, M, -, N, A, -,-,- /*,-*/),
+ !
+ ;
+ Proc = (PT->M:(N/A-MN)),
+ current_attributes(-,-,-,-, PT, M, -, N, A, MN,-,- /*,-*/)
+ ).
+
+
+current_one(Attribute = Determinism) :-
+ is_alias_for(det, Attribute),
+ current_attributes(-, -, -, -, -, -, -, -, -, -, Determinism, -
+ /*, - */),
+ !.
+
+current_one(Attribute = GoalPath) :-
+ is_alias_for(goal_path, Attribute),
+ current_attributes(-, -, -, -, -, -, -, -, -, -, -, GoalPath /*, - */),
+ !.
+
+
+% current_one(line_number = LineNumber) :-
+% is_alias_for(, Attribute),
+% current_attributes(-, -, -, -, -, -, -, -, -, -, -, -, LineNumber),
+% !.
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_list_or_conj_of_attributes_current,
+ implementation : is_list_or_conj_of_attributes_current_Op,
+ message :
+"Type which succeeds for list or conjunctions of terms of the form: \
+\"AttributeAlias = Term\", where AttributeAlias is an alias of a Mercury \
+event attribute and Term is a variable or a possible \
+value for the corresponding attribute.\n\
+Example:\n\
+current(name = Name and decl_module = module1), current([port = call, name = \
+Name]).\
+"
+ ).
+
+is_list_or_conj_of_attributes_current_Op(ListOrConj) :-
+ (
+ is_list(ListOrConj),
+ is_list_of_attributes(ListOrConj),
+ !
+ ;
+ is_conj_of_attributes(ListOrConj)
+ ).
+
+
+is_list_of_attributes([]).
+is_list_of_attributes([H | T]) :-
+ H = (Alias = Term),
+ is_alias_for(Attribute, Alias),
+ is_a_current_attribute(Attribute, Term),
+ is_list_of_attributes(T).
+
+
+is_conj_of_attributes(Alias = Term) :-
+ is_alias_for(Attribute, Alias),
+ is_a_current_attribute(Attribute, Term).
+is_conj_of_attributes(Alias = Term and Tail) :-
+ is_alias_for(Attribute, Alias),
+ is_a_current_attribute(Attribute, Term),
+ is_conj_of_attributes(Tail).
+
+
+is_a_current_attribute(Attribute, Term) :-
+ (
+ member(Attribute, [chrono, call, depth, arity, mode_number]),
+ is_integer_or_var(Term),
+ !
+ ;
+ member(Attribute, [decl_module, def_module, name, proc_type]),
+ is_atom_or_var(Term),
+ !
+ ;
+ Attribute = proc,
+ is_proc_or_var(Term),
+ !
+ ;
+ Attribute = goal_path,
+ is_goal_path_or_var(Term),
+ !
+ ;
+ Attribute = port,
+ is_port_or_var(Term),
+ !
+ ;
+ member(Attribute, [args, arg_names, arg_types]),
+ is_list_or_var(Term),
+ !
+ ;
+ Attribute = det,
+ is_det_marker_or_var(Term),
+ !
+ ;
+ member(Attribute, [vars, var_names_and_types, local_vars]),
+ is_term(Term),
+ !
+ ;
+ Attribute = stack,
+ is_list_or_var(Term)
+ ).
+
+%------------------------------------------------------------------------------%
+% opium_command(
+% name : stack,
+% arg_list : [List],
+% arg_type_list : [is_list_or_var],
+% abbrev : _,
+% interface : button,
+% command_type : opium,
+% implementation : stack_Op,
+% parameters : [],
+% message :
+% "Retrieves the ancestors stack of the call specified by the current \
+% event. This command will report an error message if there is no stack trace \
+% information available about any ancestor. \
+% "
+% ).
+
+stack1(Stack) :-
+ stack_ll_Op(Stackll),
+ stack_hl(Stackll, [], [], Stack).
+
+stack_hl([], _, Stack, Stack).
+stack_hl([level(N)|Tail], Level, Stack0, Stack) :-
+ append([[level(N)|Level]], Stack0, Stack1),
+ stack_hl(Tail, [], Stack1, Stack).
+
+stack_hl([X|Tail], Level, Stack0, Stack) :-
+ stack_hl(Tail, [X|Level], Stack0, Stack).
+
+stack_ll_Op(StackList) :-
+ getval(state_of_opium, running),
+ send_message_to_socket(stack),
+ read_message_until_end_stack([], StackList),
+ read_message_from_socket(Message),
+ (
+ Message = ok,
+ !
+ ;
+ Message = error(ErrorMessage),
+ printf(trace, "\nUnable to retrieve all the ancestors; %w.\n",
+ ErrorMessage)
+ ),
+ !.
+
+stack_ll_Op(_) :-
+ write("You can't get any stack ; no program is running.\n"),
+ fail.
+
+read_message_until_end_stack(ListIn, ListOut) :-
+ read_message_from_socket(Message),
+ ( Message = end_stack ->
+ ListOut = ListIn
+ ;
+ List = [Message|ListIn],
+ read_message_until_end_stack(List, ListOut)
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : stack,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : _,
+ interface : button,
+ command_type : opium,
+ implementation : stack_Op,
+ parameters : [],
+ message :
+"Displays the ancestors stack."
+ ).
+
+stack_Op :-
+ stack_ll_Op(StackList),
+ reverse(StackList, StackListRev),
+ display_stack(StackListRev).
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : nondet_stack,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : _,
+ implementation : nondet_stack_Op,
+ message :
+"Prints the contents of the fixed attributes of the frames on the nondet \
+stack. This command is intended to be of use only to developers \
+of the Mercury implementation."
+ ).
+
+nondet_stack_Op :-
+ getval(state_of_opium, running),
+ send_message_to_socket(nondet_stack),
+ read_message_from_socket(ok),
+ !.
+
+nondet_stack_Op :-
+ write("You can't get the nondet stack ; no program is running.\n"),
+ fail.
+
+%------------------------------------------------------------------------------%
+opium_primitive(
+ name : stack_regs,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : _,
+ implementation : stack_regs_Op,
+ message :
+"Prints the contents of the virtual machine registers that point to the det \
+and nondet stacks. This command is intended to be of use only to developers \
+of the Mercury implementation."
+ ).
+
+stack_regs_Op :-
+ getval(state_of_opium, running),
+ send_message_to_socket(stack_regs),
+ read_message_from_socket(Message),
+ Message = stack_regs(SP, CURFR, MAXFR),
+ printf(trace, "\nsp = %p, curfr = %p, maxfr = %p\n",
+ [SP, CURFR, MAXFR]),
+ !.
+
+stack_regs_Op :-
+ write("You can't get the registers stack ; no program is running.\n"),
+ fail.
+
Index: extras/opium_m/source/display_M.op
===================================================================
RCS file: display_M.op
diff -N display_M.op
--- /dev/null Wed May 28 10:49:58 1997
+++ display_M.op Tue Oct 26 23:26:34 1999
@@ -0,0 +1,1589 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier <jahier at irisa.fr>
+%
+
+opium_scenario(
+ name : display_M,
+ files : [display_M],
+ 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_opium, running) ->
+ attribute_display(ChronoFlag, CallFlag, PortFlag, DepthFlag, DeterFlag,
+ PredOrFuncFlag, DeclModuleFlag, DefModuleFlag,
+ NameFlag, ArityFlag, ModeNumFlag, ArgFlag,
+ ListVarFlag, TypeFlag, GoalPathFlag),
+ current_attributes(Chrono, Call, Depth, Port, PredOrFunc, DeclModule,
+ DefModule, Name, Arity, ModeNum, Deter, GoalPath),
+ 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_number(Port, 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),
+ 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_number(Port, LineNumber, 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]),
+ 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_number(Port, LineNumber, 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 :
+ "Procedure which displays an indentation -- if indentation is on -- \
+according to the current depth and the indentation starting depth. If \
+IndentFlag is 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 :
+ "Procedure which 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, \
+non_arg_var]. \
+To customize the way arguments are displayed, you should rather modify \
+write_arg.\
+"
+ ).
+
+%:- 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(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 :
+ "Procedure which 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 :
+"Procedure which 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 :
+"Procedure which prints an argument.\
+"
+ ).
+
+%:- 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 :
+"Procedure which 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 :
+"Procedure which 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 :
+"Procedure which 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 :
+"Procedure which 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 :
+"Parameter which tells how arguments shall be displayed. If Type is \
+\"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 :
+"Parameter which tells how lists shall be displayed. If Type is \"normal\", \
+lists are displayed in the standard Prolog way. If Type is \"nest\", \
+the nested lists are displayed only till level Range (included). If Type is \
+\"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 :
+"Parameter which tells how structured terms shall be displayed. If Type is \
+\"normal\", terms are displayed in the standard Prolog way. If Type is \
+\"nest\", \
+the nested terms are displayed only till level Range (included). If Type is \
+\"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 :
+"Paramater which tells 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 :
+"Parameter which tells 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 :
+"Parameter which tells 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) :- !.
+
+%------------------------------------------------------------------------------%
+% I copied that stuff from eclipse/opium/interface.op to avoid warnings.
+opium_procedure(
+ name : read_input,
+ arg_list : [Input],
+ implementation : read_input_Op,
+ parameters : [],
+ message :
+"Procedure which reads an input from within the current input stream \
+of Opium-M.\
+"
+ ).
+
+/* 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 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 command.\
+"
+ ).
+
+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],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [NewS, O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(call, Keyword),
+ ListDisplay = [O1, S,O3,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1, NewS,O3,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(port, Keyword),
+ ListDisplay = [O1,O2, S,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2, NewS,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13, O14,O15],
+ !
+ ;
+ is_alias_for(depth, Keyword),
+ ListDisplay = [O1,O2,O3, S,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3, NewS,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(det, Keyword),
+ ListDisplay = [O1,O2,O3,O4,S,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,NewS,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(proc_type, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,S,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,NewS,O7,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(decl_module, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,O6,S,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,O6,NewS,O8,O9,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(def_module, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,O6,O7,S,O9,O10,O11,
+ O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,NewS,O9,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(name, Keyword),
+ ListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,S,O10,O11,O12,
+ O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,NewS,O10,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(arity, Keyword),
+ ListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,O9,S,O11,O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O,O5,O6,O7,O8,O9,NewS,O11,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(mode_number, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,S,O12,O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,NewS,
+ O12,O13,O14,O15],
+ !
+ ;
+ is_alias_for(args, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,S,
+ O13,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,
+ O11,NewS,O13,O14,O15],
+ !
+ ;
+ is_alias_for(local_vars, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,S,O14,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,NewS,O14,O15],
+ !
+ ;
+ is_alias_for(arg_types, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,O12,
+ O13,S,O15],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,NewS,O15],
+ !
+ ;
+ is_alias_for(goal_path, Keyword),
+ ListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,O12,
+ O13,O14,S],
+ ( S = off ->
+ NewS = on
+ ;
+ NewS = off
+ ),
+ NewListDisplay = [O1,O2,O3,O4,O5,O6,O7,O8,O9,O10,O11,
+ O12,O13,O14,NewS]
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_procedure(
+ name : display_stack,
+ arg_list : [Stack],
+ implementation : display_stack_Op,
+ parameters : [],
+ message :
+"Procedure that 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 :
+"Display 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).
+
Index: extras/opium_m/source/error.op
===================================================================
RCS file: error.op
diff -N error.op
--- /dev/null Wed May 28 10:49:58 1997
+++ error.op Tue Oct 26 23:26:34 1999
@@ -0,0 +1,160 @@
+/*
+ * $Header: error.op,v 1.17 91/02/22 18:12:52 mireille Exp $
+ * 1990 Copyright ECRC GmbH
+ */
+
+/*
+ * ERROR Recovery system
+ * The basic idea is that, whenever it is possible, instead of
+ * outputting an error message and failing, the user is prompted until
+ * the error is corrected.
+ * (part of scenario scenario_handler)
+ */
+
+
+/*
+ * check_arg_type/4 cannot be declared as an Opium object:
+ * - it cannot be a command with type "tool" because this would call
+ * itself recursively,
+ * - it cannot be a primitive/procedure, as then we do not get the
+ * proper connection between tool name and tool body.
+ * It is always traceable because you want to see it if you debug a new
+ * command. It is skipped/unskipped depending on whether the scenario_handler
+ * scenario is made untraceable/traceable.
+ */
+
+:- tool(check_arg_type/4, check_arg_type/5).
+:- global check_arg_type/4.
+:- call_explicit(traceable check_arg_type/4, sepia_kernel).
+:- ((call(is_predicate(current_options/1), 'Opium-M'),
+ call(current_options([active, traceable, _]), 'Opium-M')) ->
+ call_explicit(unskipped check_arg_type/4, sepia_kernel)
+ ;
+ call_explicit(skipped check_arg_type/4, sepia_kernel)
+ ).
+
+
+
+/*
+ * CHECK-ARG-TYPE
+ */
+opium_procedure(
+ name : check_arg_type,
+ arg_list : [ArgValList, ArgNameList, ArgTypeList, NewValList, Module],
+ implementation : check_arg_type_Op,
+ parameters : [],
+ message :
+"Procedure which checks the types of a list of arguments. If the type of an \n\
+argument is not correct the user will be prompted for another value. If ArgVal \n\
+is [] but ArgTypeList is not [] then the procedure will prompt the user for \n\
+proper values. The types have to be visible in Module."
+ ).
+
+check_arg_type_Op(_, [], [], [], Mod) :-
+ !.
+check_arg_type_Op([Value | Vs], [Name | Ns], [Type | Ts], [NewValue | NewVs], Mod) :-
+ check_arg([Value], Name, Type, NewValue, Mod),
+ check_arg_type_Op(Vs, Ns, Ts, NewVs, Mod).
+check_arg_type_Op([], [Name | Ns], [Type | Ts], [NewValue | NewVs], Mod) :-
+ % no value given
+ check_arg([], Name, Type, NewValue, Mod),
+ check_arg_type_Op([], Ns, Ts, NewVs, Mod).
+
+
+/*
+ * CHECK-ARG
+ */
+opium_procedure(
+ name : check_arg,
+ arg_list : [ArgValue, ArgName, ArgType, NewValue, Module],
+ implementation : check_arg_Op,
+ parameters : [],
+ message :
+"Procedure which is called to check the type of a single argument. If the \n\
+type of an argument is not correct the user will be prompted for another value \n\
+until the new argument has the proper type. The type has to be visible in \n\
+Module."
+ ).
+
+check_arg_Op([], Name, Type, NewValue, Mod) :-
+ !,
+ get_correct_val(Name, Type, NewValue, Mod).
+check_arg_Op([Val], Name, Type, NewVal, Mod) :-
+ type_correct(Val, Type, Mod),
+ NewVal = Val, % to keep variable names
+ !.
+check_arg_Op([Val], Name, Type, NewVal, Mod) :-
+ get_correct_val(Name, Type, NewVal, Mod).
+
+/*
+ * prompt user for correct value
+ */
+get_correct_val(Name, is_subset(L), NewVal, Mod) :-
+ !,
+ opium_printf(output, "%w: enter a list containing values among %w or abort ?\n", [Name, L]),
+ read_input(V),
+ check_input(V, Name, is_subset(L), NewVal, Mod).
+get_correct_val(Name, is_member(L), NewVal, Mod) :-
+ !,
+ opium_printf(output, "%w: enter one value among %w or abort ?\n", [Name, L]),
+ read_input(V),
+ check_input(V, Name, is_member(L), NewVal, Mod).
+get_correct_val(Name, Cond, NewVal, Mod) :-
+ !,
+ opium_printf(output, "%w: enter one value which satisfies %w(X) or abort ?\n", [Name, Cond]),
+ read_input(V),
+ check_input(V, Name, Cond, NewVal, Mod).
+
+check_input(V, Name, Type, NewVal, Mod) :-
+ var(V),
+ !,
+ check_arg([V], Name, Type, NewVal, Mod).
+check_input(a, _, _, _, _) :-
+ !,
+ fail.
+check_input(abort, _, _, _, _) :-
+ !,
+ fail.
+check_input(V, Name, Type, NewVal, Mod) :-
+ check_arg([V], Name, Type, NewVal, Mod).
+
+/*
+ * check whether type of argument is correct
+ */
+
+type_correct(X, is_subset(L), _) :-
+ !,
+ is_subset(X, L).
+type_correct(X, is_member(L), _) :-
+ !,
+ is_member(X, L).
+type_correct(X, Cond, Module) :-
+ !,
+ Cond =.. [Pred | A],
+ Test =.. [Pred | [X | A]],
+ length([X | A], Arity),
+ type_correct_do(Test, Module).
+
+type_correct_do(is_opium_module(M), Module) :-
+ is_opium_module(M),
+ !.
+type_correct_do(is_opium_module(M), Module) :-
+ !,
+ provide_opium_module(M).
+type_correct_do(Test, Module) :-
+ call(Test, Module).
+
+is_subset([], L).
+is_subset([X|T], L) :-
+ is_member(X, L),
+ is_subset(T, L).
+
+is_member(X, L) :-
+ var(X),
+ !,
+ fail.
+is_member(X, [X|Xs]).
+is_member(X, [Y|Ys]) :-
+ is_member(X, Ys).
+
+
Index: extras/opium_m/source/event_attributes_M.op
===================================================================
RCS file: event_attributes_M.op
diff -N event_attributes_M.op
--- /dev/null Wed May 28 10:49:58 1997
+++ event_attributes_M.op Tue Oct 26 23:26:35 1999
@@ -0,0 +1,684 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier <jahier at irisa.fr>
+%
+% This files contains various types declarations concerning the event
+% attributes. Those types are used both in forward_move.op and
+% current_slots.op.
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_port,
+ implementation : is_port_Op,
+ message :
+"Type which succeeds for a Mercury Port. Mercury ports are call (or 'CALL'), \
+exit (or 'EXIT'), fail (or 'FAIL'), redo (or 'REDO'), then (or 'THEN'), \
+else (or 'ELSE'), disj (or 'DISJ'), switch (or 'SWITCH' or 'SWTC'), \
+first (or 'FIRST' or 'FRST'), later (or 'LATER' or 'LATR'), \
+exception (or 'EXCP' or 'EXCEPTION'). \
+").
+is_port_Op(Port) :-
+ is_list_of_ports_Op([Port]).
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_port_or_var,
+ implementation : is_port_or_var_Op,
+ message :
+"Type which succeeds for a Mercury port or a variable (See is_port/1).\
+").
+is_port_or_var_Op(X) :-
+ var(X), !
+ ;
+ is_port(X).
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_list_of_ports,
+ implementation : is_list_of_ports_Op,
+ message :
+"Type which succeeds for a sublist of ['CALL', 'EXIT', 'REDO', 'FAIL', 'THEN',\
+ 'ELSE', 'DISJ', 'SWITCH', 'SWTC', 'FIRST', 'FRST', 'LATER', 'LATR', 'EXCP', \
+'EXCEPTION', \
+call, exit, fail, redo, cond, then, else, disj, switch, first, later, exception, \
+neg_enter, neg_success, neg_failure].\
+").
+
+is_list_of_ports_Op(List) :-
+ list_of_mercury_ports(ListMercPorts),
+ is_sublist(List, ListMercPorts).
+
+is_sublist([], _).
+is_sublist([Term | Tail], L2) :-
+ member(Term, L2),
+ is_sublist(Tail, L2).
+
+list_of_mercury_ports([
+ 'CALL', 'EXIT', 'FAIL', 'REDO', 'THEN', 'ELSE', 'DISJ', 'SWITCH',
+ 'SWTC', 'FIRST', 'FRST', 'LATER', 'LATR', 'EXCP', 'EXCEPTION',
+ call, exit, fail, redo, cond, then, else, disj, switch, first, later,
+ exception, neg_enter, neg_success, neg_failure]).
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_port_attribute,
+ implementation : is_port_attribute_Op,
+ message :
+"Type which succeeds for a port, a negated port (not('CALL')), a list of \
+ports, '-' or a variable.\
+").
+
+
+is_port_attribute_Op(Attribute) :-
+ Attribute == '-'
+ ;
+ free(Attribute), !
+ ;
+ is_port(Attribute)
+ ;
+ Attribute = not(AttributeNeg),
+ is_port(AttributeNeg)
+ ;
+ Attribute = \+(AttributeNeg),
+ is_port(AttributeNeg)
+ ;
+ is_list_of_ports(Attribute)
+ .
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_goal_path,
+ implementation : is_goal_path_Op,
+ message :
+"Type which succeeds for list of atoms of the form '?','e', 't', '~', 'q', \
+'ci', 'si', 'di' where i is an integer > 0."
+ ).
+
+
+is_goal_path_Op([X|Xs]) :-
+ is_valid_path(X),
+ is_goal_path_Op(Xs).
+
+is_goal_path_Op([]).
+
+is_valid_path('?').
+is_valid_path(e).
+is_valid_path(t).
+is_valid_path(q).
+is_valid_path('~').
+is_valid_path(X) :-
+ atom_string(X, Xstr),
+ append_strings("d", IntStr, Xstr),
+ atom_string(Int, IntStr),
+ integer_atom(_, Int).
+is_valid_path(X) :-
+ atom_string(X, Xstr),
+ append_strings("c", IntStr, Xstr),
+ atom_string(Int, IntStr),
+ integer_atom(_, Int).
+is_valid_path(X) :-
+ atom_string(X, Xstr),
+ append_strings("s", IntStr, Xstr),
+ atom_string(Int, IntStr),
+ integer_atom(_, Int).
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_goal_path_or_var,
+ implementation : is_goal_path_or_var_Op,
+ message :
+"Type which succeeds for a Mercury goal path or a variable (See is_goal_path/1).\
+").
+
+is_goal_path_or_var_Op(X) :-
+ var(X), !
+ ;
+ is_goal_path(X).
+
+
+%------------------------------------------------------------------------------%
+% Should we need a Opium declaration for this one ?
+% :- pred is_list_of_paths(attribute).
+% :- mode is_list_of_paths(in) is semidet.
+is_list_of_goal_paths([X|Xs]) :-
+ is_goal_path(X),
+ is_list_of_goal_paths(Xs).
+
+is_list_of_goal_paths([]).
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_goal_path_attribute,
+ implementation : is_goal_path_attribute_Op,
+ message :
+"Type which succeeds for a goal path, a negated goal path, a list of \
+goal path, '-' or a variable.\
+").
+
+
+is_goal_path_attribute_Op(Attribute) :-
+ Attribute == '-'
+ ;
+ free(Attribute), !
+ ;
+ is_goal_path(Attribute)
+ ;
+ Attribute = not(AttributeNeg),
+ is_goal_path(AttributeNeg)
+ ;
+ Attribute = \+(AttributeNeg),
+ is_goal_path(AttributeNeg)
+ ;
+ is_list_of_goal_paths(Attribute)
+ .
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_atom_attribute,
+ implementation : is_atom_attribute_Op,
+ message :
+"Type which succeeds for an atom, a negated atoms, a list of atom, a variable \
+or '-'. It is intended to check proc_name def_module and \
+decl_module attributes.\
+").
+
+
+is_atom_attribute_Op(Attribute) :-
+ Attribute == '-'
+ ;
+ free(Attribute), !
+ ;
+ atom(Attribute), !
+ ;
+ Attribute = not(AttributeNeg),
+ atom(AttributeNeg), !
+ ;
+ Attribute = \+(AttributeNeg),
+ atom(AttributeNeg), !
+ ;
+ is_list_of_atoms(Attribute)
+ .
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_proc_type,
+ implementation : is_proc_type_Op,
+ message :
+"Type which succeeds for the atoms predicate and function. \
+").
+
+is_proc_type_Op(X) :-
+ member(X, [predicate, function]).
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_proc_type_attribute,
+ implementation : is_proc_type_attribute_Op,
+ message :
+"Type which succeeds for pred or func, not(pred) or not(func), \
+a list of atoms pred or func, '-' or a variable.\
+").
+
+
+is_proc_type_attribute_Op(Attribute) :-
+ Attribute == '-'
+ ;
+ free(Attribute), !
+ ;
+ member(Attribute, [predicate, function]), !
+ ;
+ Attribute = not(AttributeNeg),
+ member(AttributeNeg, [predicate, function]), !
+ ;
+ Attribute = \+(AttributeNeg),
+ member(Attribute, [predicate, function]), !
+ ;
+ subtract(Attribute, [predicate, function], [])
+ .
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_det_marker,
+ implementation : is_det_marker_Op,
+ message :
+"Type which succeeds for a Mercury determinism marker. Mercury determinism are \
+det (or 'DET'), semidet (or 'SEMI'), nondet (or 'NON'), multidet (or 'MUL'), \
+cc_nondet (or 'CCNON'), cc_multidet (or 'CCMUL'), failure (or 'FAIL') and \
+erroneous (or 'ERR'). \
+").
+is_det_marker_Op(Det) :-
+ is_list_of_dets_Op([Det]).
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_det_marker_or_var,
+ implementation : is_det_marker_or_var_Op,
+ message :
+"Type which succeeds for a Mercury determinism markers or a variable.\
+").
+
+is_det_marker_or_var_Op(X) :-
+ var(X), !
+ ;
+ is_det_marker(X).
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_list_of_dets,
+ implementation : is_list_of_dets_Op,
+ message :
+"Type which succeeds for a sublist of [det, semidet, nondet, multidet,\
+ cc_nondet, cc_multidet, failure, erroneous, 'DET', 'SEMI', 'NON', 'MUL', \
+'ERR', 'FAIL', 'CCNON', 'CCMUL'] \
+(the determinism marker in capital letters are the one use in mdb, the \
+internal Mercury debugger).\
+").
+
+is_list_of_dets_Op(List) :-
+ list_of_mercury_dets(ListMercDets),
+ is_sublist(List, ListMercDets).
+
+
+list_of_mercury_dets([det, semidet, nondet, multidet, cc_nondet,
+ cc_multidet, failure, erroneous, 'DET', 'SEMI', 'NON', 'MUL',
+ 'ERR', 'FAIL', 'CCNON', 'CCMUL']).
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_det_marker_attribute,
+ implementation : is_det_marker_attribute_Op,
+ message :
+"Type which succeeds for a Mercury determinism marker, a negated determinism \
+(not(nondet)), a list of determinism markers, '-' or a variable.\
+").
+
+
+is_det_marker_attribute_Op(Attribute) :-
+ Attribute == '-'
+ ;
+ free(Attribute), !
+ ;
+ is_det_marker(Attribute), !
+ ;
+ Attribute = not(AttributeNeg),
+ is_det_marker(AttributeNeg), !
+ ;
+ Attribute = \+(AttributeNeg),
+ is_det_marker(AttributeNeg), !
+ ;
+ is_list_of_dets(Attribute)
+ .
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_proc,
+ implementation : is_proc_Op,
+ message :
+
+"Type which succeeds for terms of the form \
+[ProcType+][Module:]ProcName[/Arity][-ModeNum] where terms betwenn square \
+bracquets are optional, ProcType has type is_proc_type_attribute/1, \
+Module and ProcName have type is_atom_attribute/1, Arity and ModeNum have \
+type is_integer_attribute/1.\
+").
+
+
+is_proc_Op(Proc) :-
+ (
+ Proc = P,
+ is_atom_attribute(P),
+ !
+ ;
+ Proc = (PT->P),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(P),
+ !
+ ;
+ Proc = M:P,
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ !
+ ;
+ Proc = P/A,
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ !
+ ;
+ Proc = P-MN,
+ is_atom_attribute(P),
+ is_integer_attribute(MN),
+ !
+ ;
+ Proc = (P/A-MN),
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ is_integer_attribute(MN),
+ !
+ ;
+ Proc = M:(P-MN),
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ is_integer_attribute(MN),
+ !
+ ;
+ Proc = M:(P/A),
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ !
+ ;
+ Proc = (PT->(P-MN)),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(P),
+ is_integer_attribute(MN),
+ !
+ ;
+ Proc = (PT->(P/A)),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ !
+ ;
+ Proc = (PT->M:P),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ !
+ ;
+ Proc = M:(P/A-MN),
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ is_integer_attribute(MN),
+ !
+ ;
+ Proc = (PT->(P/A-MN)),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ is_integer_attribute(MN),
+ !
+ ;
+ Proc = (PT->M:(P-MN)),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ is_integer_attribute(MN),
+ !
+ ;
+ Proc = (PT->M:(P/A)),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ !
+ ;
+ Proc = (PT->M:(P/A-MN)),
+ is_proc_type_attribute(PT),
+ is_atom_attribute(M),
+ is_atom_attribute(P),
+ is_integer_attribute(A),
+ is_integer_attribute(MN)
+ ).
+
+is_proc_Op(-) :-
+ !.
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_proc_or_var,
+ implementation : is_proc_or_var_Op,
+ message :
+"Type which succeeds for a Mercury procedure or a variable.\
+").
+is_proc_or_var_Op(X) :-
+ var(X), !
+ ;
+ is_proc(X).
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_arg_attribute,
+ implementation : is_arg_attribute_Op,
+ message :
+"For the time being, you can't perform filtering on arguments i.e. you can \
+only have variables or '-' for that attribute.\
+").
+is_arg_attribute_Op(Attribute) :-
+ free(Attribute) ; Attribute == '-'.
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_integer_attribute,
+ implementation : is_integer_attribute_Op,
+ message :
+"Type which succeeds for an integer, a negated integer (not 6), a list of \
+ integers ([3, 5, 9]), an interval ('3..11'), a variable or '-'.\
+"
+ ).
+is_integer_attribute_Op(Attribute) :-
+ Attribute == '-',
+ !
+ ;
+ free(Attribute),
+ !
+ ;
+ integer(Attribute),
+ !
+ ;
+ Attribute = not(AttributeNeg),
+ integer(AttributeNeg),
+ !
+ ;
+ Attribute = \+(AttributeNeg),
+ integer(AttributeNeg),
+ !
+ ;
+ is_list_of_integers(Attribute),
+ !
+ ;
+ Attribute = Bottom .. Up,
+ integer(Bottom),
+ integer(Up),
+ Bottom =< Up
+ .
+
+%:- pred is_list_of_integers(list(integer)).
+%:- mode is_list_of_integers(in) is semidet.
+is_list_of_integers([]).
+is_list_of_integers([X | Xs]) :-
+ integer(X),
+ is_list_of_integers(Xs).
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_string_attribute,
+ implementation : is_string_attribute_Op,
+ message :
+"Type which succeeds for a string, a negated string (not \"foo\"), a list of \
+ strings, a variable or '-'.\
+").
+is_string_attribute_Op(Attribute) :-
+ Attribute == '-'
+ ;
+ free(Attribute), !
+ ;
+ string(Attribute)
+ ;
+ Attribute = not(AttributeNeg),
+ string(AttributeNeg)
+ ;
+ Attribute = \+(AttributeNeg),
+ string(AttributeNeg)
+ ;
+ is_list_of_strings(Attribute)
+ .
+
+
+%:- pred is_list_of_strings(list(string)).
+%:- mode is_list_of_strings(in) is semidet.
+is_list_of_strings([]).
+is_list_of_strings([X | Xs]) :-
+ string(X),
+ is_list_of_strings(Xs).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : list_attribute_aliases,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : laa,
+ interface : hidden,
+ command_type : opium,
+ implementation : list_attribute_aliases_op,
+ parameters : [],
+ message :
+"List the available aliases for the different Mercury event attributes \
+(fget/1 and current/1).\
+").
+
+list_attribute_aliases_op :-
+ findall(X, is_alias_for(chrono, X), Lchrono),
+ findall(X, is_alias_for(call, X), Lcall),
+ findall(X, is_alias_for(depth, X), Ldepth),
+ findall(X, is_alias_for(port, X), Lport),
+ findall(X, is_alias_for(proc_type, X), LPredOrFunc),
+ findall(X, is_alias_for(decl_module, X), Ldeclmodule),
+ findall(X, is_alias_for(def_module, X), Ldefmodule),
+ findall(X, is_alias_for(name, X), Lname),
+ findall(X, is_alias_for(arity, X), Larity),
+ findall(X, is_alias_for(mode_number, X), Lmode_number),
+ findall(X, is_alias_for(proc, X), Lproc),
+ findall(X, is_alias_for(det, X), Ldet),
+ findall(X, is_alias_for(goal_path, X), Lgoal_path),
+ findall(X, is_alias_for(args, X), Largs),
+ findall(X, is_alias_for(arg_names, X), LArgsName),
+ findall(X, is_alias_for(arg_types, X), LArgsType),
+ findall(X, is_alias_for(vars, X), LVars),
+ findall(X, is_alias_for(var_names_and_types, X), Lvar_names_and_types),
+ findall(X, is_alias_for(local_vars, X), Lother),
+ findall(X, is_alias_for(stack, X), Lstack),
+ printf("List of attribute aliases for fget/1 and current/1:\n",[]),
+ printf("%19s: %w\n", [chrono, Lchrono]),
+ printf("%19s: %w\n", [call, Lcall]),
+ printf("%19s: %w\n", [depth, Ldepth]),
+ printf("%19s: %w\n", [port, Lport]),
+ printf("%19s: %w\n", [proc_type, LPredOrFunc]),
+ printf("%19s: %w\n", [def_module, Ldefmodule]),
+ printf("%19s: %w\n", [decl_module, Ldeclmodule]),
+ printf("%19s: %w\n", [name, Lname]),
+ printf("%19s: %w\n", [arity, Larity]),
+ printf("%19s: %w\n", [mode_number, Lmode_number]),
+ printf("%19s: %w\n", [proc, Lproc]),
+ printf("%19s: %w\n", [det, Ldet]),
+ printf("%19s: %w\n", [goal_path, Lgoal_path]),
+
+ printf("\nList of attribute aliases for current/1 only:\n",[]),
+ printf("%19s: %w\n", [args, Largs]),
+ printf("%19s: %w\n", [arg_names, LArgsName]),
+ printf("%19s: %w\n", [arg_types, LArgsType]),
+ printf("%19s: %w\n", [vars, LVars]),
+ printf("%19s: %w\n", [var_names_and_types, Lvar_names_and_types]),
+ printf("%19s: %w\n", [local_vars, Lother]),
+ printf("%19s: %w\n", [stack, Lstack]).
+
+%------------------------------------------------------------------------------%
+% opium_primitive(
+% name : is_alias_for,
+% arg_list : [AttributeName, Alias],
+% arg_type_list : [atom, atom],
+% implementation : is_alias_for_Op,
+% message :
+% "Succeeds if Alias is an alias for the attribute AttributeName. The aliases \
+% for all the attributes can be listed with list_attribute_aliases/0 command.
+% "
+% ).
+
+% This is used for both fget/1 and current/1 command.
+is_alias_for(chrono, chrono).
+is_alias_for(chrono, c).
+
+is_alias_for(call, call).
+is_alias_for(call, ca).
+is_alias_for(call, cl).
+
+is_alias_for(depth, depth).
+is_alias_for(depth, d).
+
+is_alias_for(port, port).
+is_alias_for(port, p).
+
+is_alias_for(proc, procedure).
+is_alias_for(proc, proc).
+
+is_alias_for(name, procedure_name).
+is_alias_for(name, proc_name).
+is_alias_for(name, name).
+is_alias_for(name, n).
+
+is_alias_for(proc_type, proc_type).
+is_alias_for(proc_type, pred_or_func).
+is_alias_for(proc_type, pof).
+
+is_alias_for(decl_module, decl_module).
+is_alias_for(decl_module, decl_mod).
+is_alias_for(decl_module, dlm).
+
+is_alias_for(def_module, def_module).
+is_alias_for(def_module, def_mod).
+is_alias_for(def_module, dfm).
+
+is_alias_for(arity, arity).
+is_alias_for(arity, ar).
+
+is_alias_for(mode_number, mode_number).
+is_alias_for(mode_number, mode_num).
+is_alias_for(mode_number, mn).
+
+is_alias_for(det, determinism).
+is_alias_for(det, deter).
+is_alias_for(det, det).
+
+is_alias_for(goal_path, goal_path).
+is_alias_for(goal_path, gp).
+
+
+% XXX Those one are not hanled in fget yet.
+is_alias_for(args, arguments).
+is_alias_for(args, args).
+is_alias_for(args, arg).
+is_alias_for(args, a).
+
+is_alias_for(arg_names, arg_names).
+is_alias_for(arg_names, an).
+
+is_alias_for(arg_types, arg_types).
+is_alias_for(arg_types, types).
+is_alias_for(arg_types, type).
+is_alias_for(arg_types, at).
+
+is_alias_for(vars, vars).
+
+is_alias_for(var_names_and_types, var_names_and_types).
+is_alias_for(var_names_and_types, vnt).
+
+is_alias_for(local_vars, local_vars).
+is_alias_for(local_vars, local_var).
+is_alias_for(local_vars, non_arg_vars).
+is_alias_for(local_vars, other_live_var).
+is_alias_for(local_vars, nav).
+
+is_alias_for(stack, stack).
+is_alias_for(stack, stk).
+is_alias_for(stack, s).
--
R1.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list