[m-dev.] Opium-M [5/5]
Erwan Jahier
Erwan.Jahier at irisa.fr
Tue Oct 26 23:47:34 AEST 1999
Index: extras/opium_m/source/source_M.op
===================================================================
RCS file: source_M.op
diff -N source_M.op
--- /dev/null Wed May 28 10:49:58 1997
+++ source_M.op Tue Oct 26 23:26:43 1999
@@ -0,0 +1,426 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier <jahier at irisa.fr>
+%
+% This file implements the source scenario.
+
+
+opium_scenario(
+ name : source_M,
+ files : [source_M],
+ scenarios : [],
+ message :
+" Scenario source provides commands to retrieve and display Mercury source \
+(and intermediate) code.\
+"
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : listing,
+ arg_list : [Module, ProcOrType, Listing],
+ arg_type_list : [is_atom_or_string, is_mercury_proc_or_type,
+ is_list_or_var],
+ abbrev : ls,
+ interface : button,
+ command_type : opium,
+ implementation : listing_Op,
+ parameters : [],
+ message :
+"Retrieves the source code of a Mercury procedure or a Mercury type \
+ProcOrType defined in the module Module and unifies it in Listing. \
+Module can be either a library or a user defined module.\
+\n\
+Note: to be able to retrieve library procedures or types with \
+listing/3, you need to have the source of the Mercury library somewhere \
+and you need \
+to make sure that the environment variable LIB_MERCURY has been set correctly \
+to the path of the Mercury library in the sh script Opium-M. \
+"
+ ).
+
+% use the default library for library modules and the current dir for the user
+% modules.
+listing_Op(Module, Name, Listing) :-
+ listing2(Module, Name, Listing, list, source).
+%------------------------------------------------------------------------------%
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : listing,
+ arg_list : [Module, PredOrFuncOrType],
+ arg_type_list : [is_atom_or_string, is_mercury_proc_or_type],
+ abbrev : ls,
+ interface : button,
+ command_type : opium,
+ implementation : listing_Op,
+ parameters : [],
+ message :
+"listing/2 is the same command as listing/3 except it prints the listing \
+of the code on the standard output.\n\
+\n\
+Example:\n\
+1 - listing(foo, bar/3, List) unify List with the list of terms defining \
+the Mercury predicate bar/3. \n\
+2 - listing(\"~/dir/foo\", bar) will display all the predicates bar/n defined \
+in the module foo which is in \"~/dir/\" directory. \n\
+3 - listing(io, io__read/3) will display the source of the Mercury library \
+predicate io__read/3 defined in the Mercury module io.\n\
+"
+ ).
+
+listing_Op(Module, Name) :-
+ listing2(Module, Name, _, stdo, source).
+%------------------------------------------------------------------------------%
+
+
+listing2(Module, Name, Listing, Where, FileType) :-
+ pathname(Module, ModulePath, ModuleName),
+ ( ModulePath \= "" ->
+ ( FileType = hlds ->
+ (
+ concat_string([ModulePath, ModuleName], FullModuleName),
+ exists(FullModuleName)
+ ->
+ listing_module(ModulePath, ModuleName, Name, Listing,
+ Where)
+ ;
+ concat_string([ModulePath, ModuleName], FullModuleName),
+ append_strings(FullModuleName2, ".hlds_dump.99-final",
+ FullModuleName),
+ concat_string([
+ "Unable to find the file %w in the directory %w. \n"
+ "You need to compile the module %w.m with"
+ " \"-dfinal\"option.\n"
+ ], Msg),
+ printf(help, Msg, [ModuleName, ModulePath, FullModuleName2])
+ )
+ ;
+ % FileType = source
+ (
+ concat_string([ModulePath, ModuleName, ".m"], Module_m),
+ exists(Module_m)
+ ->
+ ( is_mercury_library_module(ModuleName) ->
+ concat_string([ModuleName, "__", Name],
+ Name2Str),
+ atom_string(Name2, Name2Str)
+ ;
+ Name2 = Name
+ ),
+ listing_module(ModulePath, ModuleName, Name2, Listing,
+ Where)
+ ;
+ concat_string([
+ "Unable to find the module %w in the directory %w. \n"
+ "You need to compile %w%w.m with \"-dfinal\" option.\n"
+ ], Msg),
+ printf(help, Msg, [ModuleName, ModulePath, ModulePath,
+ ModuleName])
+ )
+ )
+ ;
+ % ModulePath == ""
+ ( FileType = hlds ->
+ (
+ append_strings(ModuleName2, ".hlds_dump.99-final", ModuleName),
+ is_mercury_library_module(ModuleName2)
+ ->
+ getenv("LIB_MERCURY", PathStr),
+ concat_string([PathStr, ModuleName], FileName),
+ ( exists(FileName) ->
+ listing_module(PathStr, ModuleName, Name, Listing,
+ Where)
+ ;
+ append_strings(ModuleName2, ".hlds_dump.99-final",
+ ModuleName),
+ concat_string([
+ "Unable to find the file %w in the directory %w. \n"
+ "You need to compile the module %w%w.m with"
+ "\"-dfinal\" option.\n"
+ ], Msg),
+ printf(help, Msg, [ModuleName, PathStr, PathStr,
+ ModuleName2])
+ )
+ ;
+ % is not a Mercury procedure.
+ ( exists(ModuleName) ->
+ listing_module("", ModuleName, Name, Listing, Where)
+ ;
+ append_strings(ModuleName2, ".hlds_dump.99-final",
+ ModuleName),
+ concat_string([
+ "Unable to find the module %w in the current directory. \n"
+ "You need to compile %w.m with \"-dfinal\" option.\n"
+ ], Msg),
+ printf(help, Msg, [ModuleName, ModuleName2])
+ )
+ )
+ ;
+ % FileType = source
+ (
+ is_mercury_library_module(ModuleName)
+ ->
+ getenv("LIB_MERCURY", PathStr),
+ concat_string([PathStr, ModuleName, ".m"], FileName),
+ concat_string([ModuleName, "__", Name], Name2Str),
+ atom_string(Name2, Name2Str),
+ ( exists(FileName) ->
+ listing_module(PathStr, ModuleName, Name2, Listing,
+ Where)
+ ;
+ printf(help,
+ "Unable to find the module %w in the directory %w. \n",
+ [ModuleName, PathStr])
+ )
+ ;
+ % is not a Mercury procedure.
+ (
+ concat_string([ModuleName, ".m"], Module_m),
+ exists(Module_m)
+ ->
+ listing_module("", ModuleName, Name, Listing, Where)
+ ;
+ printf(help,
+ "Unable to find the module %w in the current directory.\n",
+ [ModuleName])
+ )
+ )
+ )
+ ).
+
+
+listing_module(PathStr, ModuleStr, P/A, Listing, Where) :-
+ integer_atom(A, AAtom),
+ atom_string(AAtom, AStr),
+ atom_string(P, PStr),
+ concat_string(["listing ", PathStr, ModuleStr, " ", PStr,
+ " ", AStr], Command),
+ sh("rm -rf listing_output; touch listing_output"),
+ printf("%w.\n%b", command),
+ sh(Command),
+ ( Where = list ->
+ % Put the terms in the list Listing
+ read_listing(Listing)
+ ;
+ % Where = stdo
+ % Display the procedure on the standard output.
+ Listing = [],
+ sh("cat listing_output")
+ ).
+
+listing_module(PathStr, ModuleStr, P, Listing, Where) :-
+ atom_string(P, PStr),
+ concat_string(["listing ", PathStr, ModuleStr, " ", PStr],
+ Command),
+ sh("rm -rf listing_output; touch listing_output"),
+ printf("%w.\n%b", Command),
+ sh(Command),
+ ( Where = list ->
+ % Put the terms in the list Listing
+ read_listing(Listing)
+ ;
+ % Where = stdo
+ % Display the procedure on the standard output.
+ Listing = [],
+ sh("cat listing_output")
+ ).
+
+
+% Output in Listing the list of the read terms in the file "listing_output".
+read_listing(Listing) :-
+ open("listing_output", read, stream),
+ read_all([], Listing2),
+ close(stream),
+ reverse(Listing2, Listing).
+
+read_all(ListingIn , ListingOut) :-
+ read_mercury_term(stream, Term),
+ (
+ Term = end_of_file,
+ ListingOut = ListingIn,
+ !
+ ;
+ read_all([Term | ListingIn], ListingOut)
+ ).
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : listing_hlds,
+ arg_list : [Module, PredOrFuncOrType, Listing],
+ arg_type_list : [is_atom_or_string, is_mercury_proc_or_type,
+ is_list_or_var],
+ abbrev : _,
+ interface : hidden,
+ command_type : opium,
+ implementation : listing_hlds_Op,
+ parameters : [],
+ message :
+"See listing_hlds/2."
+ ).
+
+listing_hlds_Op(Module, Name, Listing) :-
+ pathname(Module, ModulePath, ModuleName),
+ concat_string([ModulePath, ModuleName, ".hlds_dump.99-final"], Module2),
+ listing2(Module2, Name, Listing, list, hlds).
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : listing_hlds,
+ arg_list : [Module, PredOrFuncOrType],
+ arg_type_list : [is_atom_or_string, is_mercury_proc_or_type],
+ abbrev : _,
+ interface : hidden,
+ command_type : opium,
+ implementation : listing_hlds_Op,
+ parameters : [],
+ message :
+
+"listing_hlds/2 and listing_hlds/3 are the same commands as listing/2 and \
+listing/3 except they will list the HLDS procedures instead of the source code. \
+To be able to list such HLDS code, you need to compile your module with \
+\"-dfinal\" option.\
+"
+ ).
+
+listing_hlds_Op(Module, Name) :-
+ pathname(Module, ModulePath, ModuleName),
+ concat_string([ModulePath, ModuleName, ".hlds_dump.99-final"], Module2),
+ listing2(Module2, Name, _, stdo, hlds).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : listing_current_procedure,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : lcp,
+ interface : menu,
+ command_type : opium,
+ implementation : listing_current_procedure_Op,
+ parameters : [],
+ message :
+"listing_current_procedure/0 prints the source code of the current procedure \
+on the user window. If the current procedure is defined in a file that is not \
+in the current directory, you need to specify the path of this file with \
+listing_current_procedure/1.\
+").
+
+
+% :- pred listing_current_procedure.
+% :- mode listing_current_procedure is semidet.
+listing_current_procedure_Op :-
+ current(name = Name and decl_module = Module),
+ listing(Module, Name).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : listing_current_procedure,
+ arg_list : [Path],
+ arg_type_list : [atom],
+ abbrev : lcp,
+ interface : menu,
+ command_type : opium,
+ implementation : listing_current_procedure_Op,
+ parameters : [],
+ message :
+"listing_current_procedure/1 is the same as listing_current_procedure/0 \
+except you specify the path of the module of the current procedure.\
+").
+
+% :- pred listing_current_procedure(atom).
+% :- mode listing_current_procedure(in) is semidet.
+listing_current_procedure_Op(Path) :-
+ current(name=Name),
+ current(decl_module=Module),
+ listing(Path, Module, Name).
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_mercury_proc_or_type,
+ implementation : is_mercury_proc_or_type_Op,
+ message :
+"Type which succeeds if its argument is of the form Name or \
+Name/Arity, where Name is an atom and Arity an integer.\
+").
+
+
+is_mercury_proc_or_type_Op(Name/Arity) :-
+ atom(Name),
+ integer(Arity).
+
+is_mercury_proc_or_type_Op(Name) :-
+ atom(Name).
+
+
+%------------------------------------------------------------------------------%
+is_mercury_library_module("array").
+is_mercury_library_module("int").
+is_mercury_library_module("rbtree").
+is_mercury_library_module("assoc_list").
+is_mercury_library_module("integer").
+is_mercury_library_module("relation").
+is_mercury_library_module("bag").
+is_mercury_library_module("io").
+is_mercury_library_module("require").
+is_mercury_library_module("benchmarking").
+is_mercury_library_module("lexer").
+is_mercury_library_module("set").
+is_mercury_library_module("bimap").
+is_mercury_library_module("library").
+is_mercury_library_module("set_bbbtree").
+is_mercury_library_module("bintree").
+is_mercury_library_module("list").
+is_mercury_library_module("set_ordlist").
+is_mercury_library_module("bintree_set").
+is_mercury_library_module("map").
+is_mercury_library_module("set_unordlist").
+is_mercury_library_module("bool").
+is_mercury_library_module("math").
+is_mercury_library_module("stack").
+is_mercury_library_module("bt_array").
+is_mercury_library_module("mercury_builtin").
+is_mercury_library_module("std_util").
+is_mercury_library_module("builtin").
+is_mercury_library_module("multi_map").
+is_mercury_library_module("store").
+is_mercury_library_module("char").
+is_mercury_library_module("ops").
+is_mercury_library_module("string").
+is_mercury_library_module("debugger_interface").
+is_mercury_library_module("parser").
+is_mercury_library_module("swi_builtin").
+is_mercury_library_module("dir").
+is_mercury_library_module("pqueue").
+is_mercury_library_module("swi_lib").
+is_mercury_library_module("eqvclass").
+is_mercury_library_module("private_builtin").
+is_mercury_library_module("term").
+is_mercury_library_module("float").
+is_mercury_library_module("prolog").
+is_mercury_library_module("term_io").
+is_mercury_library_module("getopt").
+is_mercury_library_module("queue").
+is_mercury_library_module("tree234").
+is_mercury_library_module("graph").
+is_mercury_library_module("random").
+is_mercury_library_module("varset").
+is_mercury_library_module("group").
+is_mercury_library_module("rational").
+
+
+%------------------------------------------------------------------------------%
+opium_type(
+ name : is_atom_or_string,
+ implementation : is_atom_or_string_Op,
+ message :
+"Type which succeed for an atom or a string."
+ ).
+
+is_atom_or_string_Op(X) :- atom(X), !.
+is_atom_or_string_Op(X) :- string(X).
Index: extras/opium_m/source/step_by_step_M.op
===================================================================
RCS file: step_by_step_M.op
diff -N step_by_step_M.op
--- /dev/null Wed May 28 10:49:58 1997
+++ step_by_step_M.op Tue Oct 26 23:26:43 1999
@@ -0,0 +1,190 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Author : Erwan Jahier <jahier at irisa.fr>
+%
+
+opium_scenario(
+ name : step_by_step_M,
+ files : [step_by_step_M],
+ scenarios : [],
+ message :
+"Scenario which provides standard step by step tracing facilities. The tracing \
+commands of this scenario are different from those of the ``kernel'' scenario. \
+User can use a more simple execution model by setting the ``traced_ports'' \
+parameter which filters out some of the traced events."
+ ).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : next,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : n,
+ interface : button,
+ command_type : trace,
+ implementation : next_Op,
+ parameters : [traced_ports],
+ message :
+"Command which moves forward to the next trace event according to the \
+``traced_ports'' parameter. This is the same command as step/0 (``next'' is \
+the name used in the Prolog version of Opium, ``step'' is the name used in the \
+internal Mercury debugger)."
+ ).
+
+
+opium_command(
+ name : step,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : _,
+ interface : hidden,
+ command_type : trace,
+ implementation : next_Op,
+ parameters : [traced_ports],
+ message :
+"See next/0."
+ ).
+
+next_Op :-
+ traced_ports(PortList),
+ fget_np(port = PortList).
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : det_next,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : _,
+ interface : menu,
+ command_type : trace,
+ implementation : det_next_Op,
+ parameters : [traced_ports],
+ message :
+"Command which does the same thing as step/0, but it is not backtrackable."
+ ).
+
+opium_command(
+ name : det_step,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : _,
+ interface : hidden,
+ command_type : trace,
+ implementation : det_next_Op,
+ parameters : [traced_ports],
+ message :
+"See det_next/0."
+ ).
+
+det_next_Op :-
+ next_np,
+ !.
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : next,
+ arg_list : [N],
+ arg_type_list : [integer],
+ abbrev : n,
+ interface : menu,
+ command_type : opium,
+ implementation : next_Op,
+ parameters : [traced_ports],
+ message :
+"Command which prints the N next trace events according to the ``traced_ports'' \
+parameter."
+ ).
+
+opium_command(
+ name : step,
+ arg_list : [N],
+ arg_type_list : [integer],
+ abbrev : _,
+ interface : hidden,
+ command_type : opium,
+ implementation : next_Op,
+ parameters : [traced_ports],
+ message :
+"See next/1."
+ ).
+
+next_Op(N) :-
+ N =< 0,
+ !.
+next_Op(N) :-
+ setval(next_counter, N),
+ next,
+ decval(next_counter),
+ getval(next_counter, 0),
+ !.
+
+
+%------------------------------------------------------------------------------%
+opium_command(
+ name : finish,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : f,
+ interface : button,
+ command_type : trace,
+ implementation : skip_Op,
+ parameters : [],
+ message :
+"Command which makes the execution continuing until it reaches a final port \
+(exit or fail) of the goal to which the current event refers. If the current \
+port is already final, it acts like a step/0.\n\
+It is the same command as skip/0 (``skip'' is the name used in the Prolog \
+version of Opium, ``finish'' is the name used in the internal Mercury \
+debugger)."
+).
+
+opium_command(
+ name : skip,
+ arg_list : [],
+ arg_type_list : [],
+ abbrev : sk,
+ interface : hidden,
+ command_type : trace,
+ implementation : skip_Op,
+ parameters : [],
+ message :
+ "See finish/0."
+ ).
+
+skip_Op :-
+ current(port = Port),
+ skip_int(Port).
+
+skip_int(Port) :-
+ is_quit_port(Port),
+ !,
+ det_next_np.
+skip_int(_) :-
+ current(call = Call),
+ fget_np(call = Call and port = [exit, fail]),
+ !.
+
+is_quit_port(exit).
+is_quit_port(fail).
+
+
+%------------------------------------------------------------------------------%
+opium_parameter(
+ name : traced_ports,
+ arg_list : [PortList],
+ arg_type_list : [is_list_of_ports],
+ parameter_type : single,
+ default : [[call, exit, fail, redo, then, else,
+ switch, disj, first, later]],
+ commands : [next],
+ message :
+"Parameter which tells which events (w.r.t. ports) are to be traced by \
+commands ``next'' and ``step''."
+ ).
+
+
+
Index: extras/opium_m/source/translate.op
===================================================================
RCS file: translate.op
diff -N translate.op
--- /dev/null Wed May 28 10:49:58 1997
+++ translate.op Tue Oct 26 23:26:44 1999
@@ -0,0 +1,758 @@
+/*
+ * $Header: translate.op,v 1.38 94/05/05 11:14:49 sepia Exp $
+ * 1990 Copyright ECRC GmbH
+ */
+
+/*
+ * translate a file *.op containing all kinds of Opium objects,
+ * collect the declarations, autoload stuff etc. in
+ * two files *.load and *.autoload
+ * (part of scenario scenario)
+ */
+
+
+/*
+ * translate_file(Scenario, SourceFile, LoadFile, AutoLoadFile, SrcDir, Mod)
+ */
+translate_file(Scenario, SrcFile, LoadFile, AutoLoadFile, SrcDir, Mod) :-
+ open(LoadFile, write, Load),
+ open(AutoLoadFile, write, AutoLoad),
+ translate_file_i(Scenario, SrcFile, Load, AutoLoad, SrcDir, Mod),
+ close(Load),
+ close(AutoLoad),
+ printf(output, "%w is translated\n", [SrcFile]),
+ !.
+translate_file(Scenario, SrcFile, LoadFile, AutoLoadFile, SrcDir, _) :-
+ printf(output, "could not translate %w\n", [SrcFile]).
+
+translate_file_i(Scenario, SrcFile, Load, Autoload, SrcDir, Mod) :-
+ printf(output, "translating %w\n", [SrcFile]),
+ build_load(Scenario, SrcFile, Load, Autoload, SrcDir, Mod).
+
+/*
+ * build_load/6
+ * generates files *.load and *.autoload containing the information
+ * which is needed for on-line help, treatment of flags and parameters,
+ * etc. when a scenario is loaded
+ */
+build_load(Scenario, File, Load, Autoload, SrcDir, Mod) :-
+ existing(File),
+ open(File, read, ReadFile),
+ repeat,
+ read(ReadFile, X),
+ ( X = end_of_file,
+ !,
+ close(ReadFile)
+ ;
+ (X = (?- global_op(P,A,N)) ; X = (:- global_op(P,A,N))),
+ % to avoid errors when parsing the rest of the file
+ op(P,A,N),
+ fail
+ ;
+ (X = (?- op(P,A,N)) ; X = (:- op(P,A,N))),
+ % to avoid errors when parsing the rest of the file
+ op(P,A,N),
+ fail
+ ;
+ build_load_i(X, Scenario, Load, Autoload, SrcDir, Mod),
+ fail
+ ).
+
+existing(File) :-
+ exists(File),
+ !.
+existing(File) :-
+ printf(error, "file %w does not exist\n", [File]),
+ fail.
+
+
+/* The information about opium objects is added automatically by Opium
+ * during the translation, hence the declarations are different when they
+ * are in the source file *.op and when loaded. The latters have an
+ * additional field "scenario".
+ */
+build_load_i(
+ opium_scenario(
+ name : Name,
+ files : Files,
+ scenarios : NeededScenarios,
+ message : Message
+ ),
+ Scenario, Load, Autoload, SrcDir, Mod
+) :-
+ !,
+ check_declaration(scenario,
+ opium_scenario(
+ name : Name,
+ files : Files,
+ scenarios : NeededScenarios,
+ message : Message
+ )),
+ absolute_pathnames(SrcDir, Files, AbsoluteFiles),
+ build_scenario(Load, Autoload,
+ opium_scenario(
+ name : Name,
+ files : AbsoluteFiles,
+ scenarios : NeededScenarios,
+ options : OptionList,
+ updated : UpdateTime,
+ message : Message
+ )),
+ !.
+build_load_i(
+ opium_command(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ interface : Interface,
+ command_type : CommandType,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ ),
+ Scenario, Load, Autoload, SrcDir, Mod
+) :-
+ !,
+ check_declaration(command,
+ opium_command(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ interface : Interface,
+ command_type : CommandType,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ )),
+ build_cmd(Load, Autoload, Name, ArgList, ArgType, Abbrev,
+ CommandType, Procedure, Scenario,
+ opium_command(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ interface : Interface,
+ command_type : CommandType,
+ scenario : Scenario,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ )),
+ !.
+build_load_i(
+ opium_procedure(
+ name : Name,
+ arg_list : ArgList,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ ),
+ Scenario, Load, Autoload, SrcDir, Mod
+) :-
+ !,
+ check_declaration(procedure,
+ opium_procedure(
+ name : Name,
+ arg_list : ArgList,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ )),
+ build_procedure(Load, Name, ArgList, Procedure, Scenario,
+ opium_procedure(
+ name : Name,
+ arg_list : ArgList,
+ scenario : Scenario,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ )),
+ !.
+build_load_i(
+ opium_parameter(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ parameter_type : ParType,
+ default : DefaultArg,
+ commands : CommandList,
+ message : Message),
+ Scenario, Load, Autoload, SrcDir, Mod
+) :-
+ !,
+ check_declaration(parameter,
+ opium_parameter(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ parameter_type : ParType,
+ default : DefaultArg,
+ commands : CommandList,
+ message : Message
+ ), Mod),
+ build_parameter(Load, Name, ArgList, ArgType, DefaultArg, Scenario,
+ opium_parameter(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ scenario : Scenario,
+ parameter_type : ParType,
+ default : DefaultArg,
+ commands : CommandList,
+ message : Message
+ )),
+ !.
+build_load_i(
+ opium_primitive(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ implementation : Procedure,
+ message : Message),
+ Scenario, Load, Autoload, SrcDir, Mod
+) :-
+ !,
+ check_declaration(primitive,
+ opium_primitive(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ implementation : Procedure,
+ message : Message
+ )),
+ build_primitive(Load, Name, ArgList, ArgType, Abbrev, Procedure, Scenario,
+ opium_primitive(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ scenario : Scenario,
+ implementation : Procedure,
+ message : Message
+ )),
+ !.
+build_load_i(
+ opium_type(
+ name : Name,
+ implementation : Procedure,
+ message : Message),
+ Scenario, Load, Autoload, SrcDir, Mod
+) :-
+ !,
+ check_declaration(type,
+ opium_type(
+ name : Name,
+ implementation : Procedure,
+ message : Message
+ )),
+ build_type(Load, Name, Procedure, Scenario,
+ opium_type(
+ name : Name,
+ scenario : Scenario,
+ implementation : Procedure,
+ message : Message
+ )),
+ !.
+build_load_i(
+ opium_demo(
+ name : Name,
+ demo_goal : Goal,
+ condition : Condition,
+ message : Message),
+ Scenario, Load, Autoload, SrcDir, Mod
+) :-
+ !,
+ check_declaration(demo,
+ opium_demo(
+ name : Name,
+ demo_goal : Goal,
+ condition : Condition,
+ message : Message
+ )),
+ build_demo(Load, Name, Goal, Condition, Message, Scenario,
+ opium_demo(
+ name : Name,
+ demo_goal : Goal,
+ condition : Condition,
+ scenario : Scenario,
+ message : Message
+ )),
+ !.
+/* for the normal clauses */
+build_load_i((:- X), Scenario, Load, Autoload, SrcDir, Mod) :-
+ !.
+build_load_i((?- X), Scenario, Load, Autoload, SrcDir, Mod) :-
+ !.
+build_load_i((X :- Y), Scenario, Load, Autoload, SrcDir, Mod) :-
+ !,
+ functor(X, Pred, Arity),
+ ( is_opium_declaration(Pred/_),
+ !,
+ X =.. [_ | [name:Name | _]],
+ printf(error, "%w %w not properly declared\n", [Pred, Name])
+ ;
+ true
+ ).
+build_load_i(X, Scenario, Load, Autoload, SrcDir, Mod) :-
+ functor(X, Pred, Arity),
+ ( is_opium_declaration(Pred/_),
+ !,
+ X =.. [_ | [name:Name | _]],
+ printf(error, "%w %w not properly declared\n", [Pred, Name])
+ ;
+ true
+ ).
+
+
+/*
+ * BUILD-SCENARIO
+ */
+build_scenario(Load, AutoLoad, Clause) :-
+ opium_assert(Load, :- load_decl(Clause)),
+ opium_assert(AutoLoad, :- load_decl(Clause)).
+
+
+/*
+ * BUILD-COMMAND
+ *
+ * build_cmd builds the command according to the command type:
+ * opium : can be called any time but in an Opium session only
+ * trace : requires an execution, produces trace line
+ * tool : tool wrt Sepia's module system (requires current module)
+ *
+ * Checking of argument types and print_event are added if required,
+ * primitives are generated automatically.
+ */
+build_cmd(Load, Autoload, Name, ArgList, TypeList, Abbrev, CommandType, Procedure, Scenario, Clause) :-
+ opium_assert(Load, :- load_decl(Clause)),
+ build_cmd_int(CommandType, Load, Autoload, Name, ArgList, TypeList, Abbrev, Procedure, Scenario).
+
+build_cmd_int(opium, Load, Autoload, Name, [], [], Abbrev, Impl, Scenario) :-
+ !,
+ opium_assert(Load, (Name :- Impl)),
+ build_autoload_info(Autoload, Name, Name, Scenario),
+ build_abbrev(Load, Autoload, Name, [], Abbrev, Scenario).
+build_cmd_int(opium, Load, Autoload, Name, ArgList, TypeList, Abbrev, Impl, Scenario) :-
+ !,
+ length(ArgList, Arity),
+ Cmd1 =.. [Name | ArgList],
+ name_variables(ArgList, ArgNameList),
+ opium_assert(Load,
+ (Cmd1 :-
+ check_arg_type(ArgList, ArgNameList, TypeList, NewList),
+ Cmd2 =.. [Impl | NewList],
+ Cmd2)),
+ build_autoload_info(Autoload, Cmd1, Name, Scenario),
+ build_abbrev(Load, Autoload, Name, ArgList, Abbrev, Scenario).
+build_cmd_int(trace, Load, Autoload, Name, [], [], Abbrev, Impl, Scenario) :-
+ !,
+ concat_atom([Name, '_np'], Name_np),
+ opium_assert(Load, (Name :- Name_np, print_event)),
+ build_related_primitives(trace, Load, Name, Name_np, Impl, [], [], Abbrev, Scenario),
+ build_autoload_info(Autoload, Name, Name, Scenario),
+ build_abbrev(Load, Autoload, Name, [], Abbrev, Scenario).
+build_cmd_int(trace, Load, Autoload, Name, ArgList, TypeList, Abbrev, Impl, Scenario) :-
+ length(ArgList, Arity),
+ Cmd1 =.. [Name | ArgList],
+ concat_atom([Name, '_np'], Name_np),
+ name_variables(ArgList, ArgNameList),
+ opium_assert(Load,
+ (Cmd1 :-
+ check_arg_type(ArgList, ArgNameList, TypeList, NewList),
+ Cmd2 =.. [Name_np | NewList],
+ Cmd2,
+ print_event)),
+ build_related_primitives(trace, Load, Name, Name_np, Impl, ArgList, TypeList, Abbrev, Scenario),
+ build_autoload_info(Autoload, Cmd1, Name, Scenario),
+ build_abbrev(Load, Autoload, Name, ArgList, Abbrev, Scenario).
+build_cmd_int(tool, Load, Autoload, Name, [], [], Abbrev, Impl, Scenario) :-
+ !,
+ concat_atoms(Name, '_body', BodyName),
+ BodyCmd1 =.. [BodyName | [ActModule]],
+ BodyCmd2 =.. [Impl | [ActModule]],
+ opium_assert(Load, (:- tool(Name/0, BodyName/1))),
+ opium_assert(Load, (BodyCmd1 :- BodyCmd2)),
+ build_autoload_info(Autoload, Name, Name, Scenario),
+ build_tool_abbrev(Load, Autoload, BodyName/1, Abbrev/0, [], Scenario).
+build_cmd_int(tool, Load, Autoload, Name, ArgList, TypeList, Abbrev, Impl, Scenario) :-
+ length(ArgList, Arity),
+ BodyArity is Arity + 1,
+ append(ArgList, [ActModule], BodyArgList),
+ name_variables(BodyArgList, BodyArgNameList),
+ append(TypeList, [is_opium_module], BodyTypeList),
+ concat_atoms(Name, '_body', BodyName),
+ BodyCmd1 =.. [BodyName | BodyArgList],
+ opium_assert(Load, (:- tool(Name/Arity, BodyName/BodyArity))),
+ opium_assert(Load,
+ (BodyCmd1 :-
+ check_arg_type(BodyArgList, BodyArgNameList, BodyTypeList, NewList),
+ BodyCmd2 =.. [Impl | NewList],
+ BodyCmd2)),
+ Cmd =.. [Name | ArgList],
+ build_autoload_info(Autoload, Cmd, Name, Scenario),
+ build_tool_abbrev(Load, Autoload, BodyName/BodyArity, Abbrev/Arity, ArgList, Scenario).
+
+
+/*
+ * build_abbrev/6
+ * connect abbreviation and command, add autoload info to Autoload
+ */
+build_abbrev(Load, Autoload, Name, ArgList, Abbrev, Scenario) :-
+ var(Abbrev),
+ !.
+build_abbrev(Load, Autoload, Name, ArgList, Abbrev, Scenario) :-
+ length(ArgList, Arity),
+ AbbrevCmd =.. [Abbrev | ArgList],
+ FullCmd =.. [Name | ArgList],
+ opium_assert(Load, (AbbrevCmd :- FullCmd)),
+ build_autoload_info(Autoload, AbbrevCmd, Abbrev, Scenario),
+ !.
+build_abbrev(_,_,_,_,_,_).
+
+/*
+ * build_tool_abbrev/6
+ * declare abbreviation as tool, add autoload info to Autoload
+ */
+build_tool_abbrev(Load, Autoload, BodyName/BodyArity, Abbrev/Arity, ArgList, Scenario) :-
+ var(Abbrev),
+ !.
+build_tool_abbrev(Load, Autoload, BodyName/BodyArity, Abbrev/Arity, ArgList, Scenario) :-
+ opium_assert(Load, :- tool(Abbrev/Arity, BodyName/BodyArity)),
+ AbbrevCmd =.. [Abbrev | ArgList],
+ build_autoload_info(Autoload, AbbrevCmd, Abbrev, Scenario),
+ !.
+build_tool_abbrev(_,_,_,_,_,_).
+
+
+/*
+ * build-related-primitives
+ */
+build_related_primitives(trace, Load, Cmd, Cmd_np, Impl, ArgList, TypeList, Abbrev, Scenario) :-
+ build_primitive_abbreviation(Abbrev, [Abbrev, '_np'], PrimAbbrev),
+ sprintf(Message, "Primitive which does the same as command %w except printing a trace line.", [Cmd]),
+ build_primitive(Load, Cmd_np, ArgList, TypeList, PrimAbbrev, Impl, Scenario,
+ opium_primitive(
+ name : Cmd_np,
+ arg_list : ArgList,
+ arg_type_list : TypeList,
+ abbrev : PrimAbbrev,
+ scenario : Scenario,
+ implementation : Impl,
+ message : Message
+ )).
+
+build_primitive_abbreviation(Abbrev, List, PAbbrev) :-
+ var(Abbrev),
+ !.
+build_primitive_abbreviation(Abbrev, List, PAbbrev) :-
+ concat_atom(List, PAbbrev).
+
+build_autoload_info(Autoload, Cmd, Cmd, Scenario) :- % no arguments
+ !,
+ opium_assert(Autoload, :- assert(autoload_command(Cmd, Scenario))).
+build_autoload_info(Autoload, Cmd, CmdName, Scenario) :-
+ opium_assert(Autoload, :- assert(autoload_command(Cmd, Scenario))),
+ opium_assert(Autoload, :- assert(autoload_command(CmdName, Scenario))).
+
+
+/*
+ * BUILD-PRIMITIVE
+ */
+build_primitive(Load, Name, ArgList, TypeList, Abbrev, Impl, Scenario, Clause) :-
+ length(ArgList, Arity),
+ Cmd1 =.. [Name | ArgList],
+ Cmd2 =.. [Impl | ArgList],
+ opium_assert(Load, (Cmd1 :- Cmd2)),
+ opium_assert(Load, :- load_decl(Clause)),
+ build_abbrev(Load, Name, ArgList, Abbrev, Scenario).
+
+/*
+ * build_abbrev/5
+ * like build_abbrev/6, but for primitives (no autoload info)
+ */
+build_abbrev(Load, Name, ArgList, Abbrev, Scenario) :-
+ var(Abbrev),
+ !.
+build_abbrev(Load, Name, ArgList, Abbrev, Scenario) :-
+ length(ArgList, Arity),
+ AbbrevCmd =.. [Abbrev | ArgList],
+ FullCmd =.. [Name | ArgList],
+ opium_assert(Load, (AbbrevCmd :- FullCmd)),
+ !.
+build_abbrev(_,_,_,_,_).
+
+
+
+/*
+ * BUILD-TYPE
+ */
+build_type(Load, Name, Impl, Scenario, Clause) :-
+ Cmd1 =.. [Name | [X]],
+ Cmd2 =.. [Impl | [X]],
+ opium_assert(Load, (Cmd1 :- Cmd2)),
+ opium_assert(Load, :- load_decl(Clause)).
+
+
+/*
+ * BUILD-DEMO
+ */
+build_demo(Load, Name, Goal, Condition, Message, Scenario, Clause) :-
+ opium_assert(Load,
+ (Name :-
+ Condition,
+ printf(help, "\n%w\n\n%w\n\n", [Goal, Message]),
+ execute_demo_goal(Goal)
+ )),
+ opium_assert(Load, :- load_decl(Clause)).
+
+
+/*
+ * BUILD-PROCEDURE
+ */
+build_procedure(Load, Name, ArgList, Procedure, Scenario, Clause):-
+ Cmd1 =.. [Name | ArgList],
+ Cmd2 =.. [Procedure | ArgList],
+ opium_assert(Load, (Cmd1 :- Cmd2)),
+ opium_assert(Load, :- load_decl(Clause)),
+ length(ArgList, Arity).
+
+
+/*
+ * BUILD-PARAMETER
+ */
+build_parameter(Load, Name, ArgList, ArgType, DefaultArg, Scenario, Clause) :-
+ Par =.. [Name | ArgList],
+ functor(Par, Name, Arity),
+ opium_assert(Load, :- dynamic Name/Arity),
+ opium_assert(Load, :- load_decl(Clause)).
+
+
+
+/*
+ * CHECK-DECLARATION
+ * checks whether the declaration of an Opium object seems to be
+ * correct; does not give proper error message but simply tells
+ * the user if a declaration looks incorrect
+ */
+check_declaration(scenario,
+ opium_scenario(
+ name : Name,
+ files : Files,
+ scenarios : NeededScenarios,
+ message : Message
+ ))
+:-
+ ( atom(Name),
+ is_list_of_atoms(Files),
+ is_list_of_atoms_or_empty_list(NeededScenarios),
+ !
+ ;
+ printf(error, "scenario %w is not properly declared\n", [Name]),
+ fail
+ ).
+check_declaration(command,
+ opium_command(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ interface : Interface,
+ command_type : CommandType,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ ))
+:-
+ ( atom(Name),
+ is_list_of_vars_or_empty_list(ArgList),
+ length(ArgList, L),
+ is_list(ArgType),
+ length(ArgType, L),
+ member(Interface, [button, menu, hidden]),
+ member(CommandType, [opium, trace, tool]),
+ atom(Procedure),
+ is_list(ParameterList),
+ !
+ ;
+ printf(error, "command %w is not properly declared\n", [Name]),
+ fail
+ ).
+check_declaration(procedure,
+ opium_procedure(
+ name : Name,
+ arg_list : ArgList,
+ implementation : Procedure,
+ parameters : ParameterList,
+ message : Message
+ ))
+:-
+ ( atom(Name),
+ is_list_of_vars_or_empty_list(ArgList),
+ atom(Procedure),
+ is_list(ParameterList),
+ !
+ ;
+ printf(error, "procedure %w is not properly declared\n", [Name]),
+ fail
+ ).
+check_declaration(primitive,
+ opium_primitive(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ abbrev : Abbrev,
+ implementation : Procedure,
+ message : Message
+ ))
+:-
+ ( atom(Name),
+ is_list_of_vars_or_empty_list(ArgList),
+ length(ArgList, L),
+ is_list(ArgType),
+ length(ArgType, L),
+ atom(Procedure),
+ !
+ ;
+ printf(error, "primitive %w is not properly declared\n", [Name]),
+ fail
+ ).
+check_declaration(type,
+ opium_type(
+ name : Name,
+ implementation : Procedure,
+ message : Message
+ ))
+:-
+ ( atom(Name),
+ atom(Procedure),
+ !
+ ;
+ printf(error, "type %w is not properly declared\n", [Name]),
+ fail
+ ).
+check_declaration(demo,
+ opium_demo(
+ name : Name,
+ demo_goal : Goal,
+ condition : Condition,
+ message : Message
+ ))
+:-
+ ( atom(Name),
+ !
+ ;
+ printf(error, "demo %w is not properly declared\n", [Name]),
+ fail
+ ).
+
+check_declaration(parameter,
+ opium_parameter(
+ name : Name,
+ arg_list : ArgList,
+ arg_type_list : ArgType,
+ parameter_type : ParType,
+ default : DefaultArg,
+ commands : CommandList,
+ message : Message
+ ), Mod)
+:-
+ ( atom(Name),
+ is_list_of_vars_or_empty_list(ArgList),
+ length(ArgList, L),
+ is_list(ArgType),
+ length(ArgType, L),
+ default_args_correct(Name, ArgType, DefaultArg, Mod),
+ is_list(CommandList),
+ member(ParType, [c, single, multiple]),
+ !
+ ;
+ printf(error, "parameter %w is not properly declared\n", [Name]),
+ fail
+ ).
+
+default_args_correct(Name, ArgTypeList, DefaultArg, Mod) :-
+ var(DefaultArg),
+ !,
+ printf(error, "default of parameter %w must not be a variable\n", [Name]),
+ fail.
+default_args_correct(Name, ArgTypeList, nodefault, Mod) :-
+ !.
+default_args_correct(Name, ArgTypeList, DefaultArg, Mod) :-
+ is_list(DefaultArg),
+ !.
+default_args_correct(Name, ArgTypeList, DefaultArg, Mod) :-
+ printf(error, "default values of parameter %w have to be in a list\n", [Name]),
+ fail.
+
+
+/*
+ * IS-LIST-OF-VARS-OR-EMPTY-LIST
+ */
+opium_type(
+ name : is_list_of_vars_or_empty_list,
+ implementation : is_list_of_vars_or_empty_list_Op,
+ message :
+'Type which succeeds for a list of variables, or the empty list.'
+ ).
+
+is_list_of_vars_or_empty_list_Op([]).
+is_list_of_vars_or_empty_list_Op([V | Vs]) :-
+ var(V),
+ is_list_of_vars_or_empty_list_Op(Vs).
+
+
+/*
+ * IS-LIST-OF-ATOMS-OR-EMPTY-LIST
+ */
+opium_type(
+ name : is_list_of_atoms_or_empty_list,
+ implementation : is_list_of_atoms_or_empty_list_Op,
+ message :
+'Type which succeeds for a list containing atoms, or an empty list.'
+ ).
+
+is_list_of_atoms_or_empty_list_Op(L) :-
+ is_list_of_atoms(L),
+ !.
+is_list_of_atoms_or_empty_list_Op([]).
+
+
+/*
+ * IS-OPIUM-DECLARATION
+ */
+opium_type(
+ name : is_opium_declaration,
+ implementation : is_opium_declaration_Op,
+ message :
+ 'Type which succeeds for an opium object (eg. opium_command/9). The \n\
+arity of the predicate must be the arity of the declaration in the source.'
+ ).
+/*
+ * Arity of the declaration in the source.
+ */
+is_opium_declaration_Op(opium_command/9).
+is_opium_declaration_Op(opium_parameter/8).
+is_opium_declaration_Op(opium_primitive/6).
+is_opium_declaration_Op(opium_procedure/5).
+is_opium_declaration_Op(opium_scenario/4).
+is_opium_declaration_Op(opium_type/3).
+is_opium_declaration_Op(opium_demo/4).
+
+
+/* ---------------------------------
+ * b a s i c p r e d i c a t e s
+ * ---------------------------------
+ */
+
+name_variables([], []).
+name_variables([V|Vs], [NV|NVs]) :-
+ namevar(V, NV),
+ name_variables(Vs, NVs).
+
+opium_assert(Stream, Clause) :-
+ printf(Stream, "\n%QDw.\n", Clause).
+
Index: extras/opium_m/source/types.op
===================================================================
RCS file: types.op
diff -N types.op
--- /dev/null Wed May 28 10:49:58 1997
+++ types.op Tue Oct 26 23:26:44 1999
@@ -0,0 +1,335 @@
+/*
+ * $Header: types.op,v 1.16 91/02/25 11:35:00 mireille Exp $
+ * 1990 Copyright ECRC GmbH
+ */
+
+/*
+ * definitions of opium_types
+ * part of scenario scenario
+ */
+
+
+/*
+ * IS-PRED
+ */
+opium_type(
+ name : is_pred,
+ implementation : is_pred_Op,
+ message :
+"Type which succeeds for a predicate id of the form P/A or M:P/A. The \n\
+default module is the toplevel module in the traced session."
+ ).
+
+is_pred_Op(M:P/A) :-
+ atom(M),
+ atom(P),
+ integer(A).
+is_pred_Op(P/A) :-
+ atom(P),
+ integer(A).
+
+
+/*
+ * IS-PRED-ID
+ */
+opium_type(
+ name : is_pred_id,
+ implementation : is_pred_id_Op,
+ message :
+"Type which succeeds for a predicate id which consists of P/A only."
+ ).
+
+is_pred_id_Op(P/A) :-
+ atom(P),
+ integer(A).
+
+
+
+/*
+ * IS-GOAL-OR-VAR
+ */
+opium_type(
+ name : is_goal_or_var,
+ implementation : is_goal_or_var_Op,
+ message :
+ 'Type which succeeds for a term which is either a var, a compound \n\
+term or an atom.'
+ ).
+
+is_goal_or_var_Op(X) :-
+ var(X),
+ !.
+is_goal_or_var_Op(X) :-
+ is_goal(X).
+
+/*
+ * IS-GOAL
+ */
+opium_type(
+ name : is_goal,
+ implementation : is_goal_Op,
+ message :
+'Type which succeeds for a term which is either a compound term or an atom.'
+ ).
+
+is_goal_Op(X) :-
+ compound(X),
+ !.
+is_goal_Op(X) :-
+ atom(X).
+
+
+/*
+ * IS-LIST
+ */
+opium_type(
+ name : is_list,
+ implementation : is_list_Op,
+ message :
+"Type which succeeds for any list."
+ ).
+
+is_list_Op(X) :-
+ var(X),
+ !,
+ fail.
+is_list_Op([]).
+is_list_Op([A | L]).
+
+/*
+ * IS-TERM
+ */
+opium_type(
+ name : is_term,
+ implementation : is_term_Op,
+ message :
+"Type which succeeds for any Prolog term."
+ ).
+
+is_term_Op(X).
+
+
+/*
+ * IS-PRED-OR-VAR
+ */
+opium_type(
+ name : is_pred_or_var,
+ implementation : is_pred_or_var_Op,
+ message :
+"Type which succeeds for a predicate id of the form P/A, or M:P/A, or a \n\
+variable. The default module is the toplevel module in the traced session."
+ ).
+
+is_pred_or_var_Op(Pred) :-
+ var(Pred),
+ !.
+is_pred_or_var_Op(Module:Pred/Arity) :-
+ var(Module),
+ var(Pred),
+ var(Arity),
+ !.
+is_pred_or_var_Op(Pred) :-
+ is_pred(Pred).
+
+
+/*
+ * IS-INTEGER-OR-VAR
+ */
+opium_type(
+ name : is_integer_or_var,
+ implementation : is_integer_or_var_Op,
+ message :
+"Type which succeeds for an integer or a variable."
+ ).
+
+is_integer_or_var_Op(I) :-
+ var(I),
+ !.
+is_integer_or_var_Op(I) :-
+ integer(I).
+
+
+/*
+ * IS-ATOM-OR-VAR
+ */
+opium_type(
+ name : is_atom_or_var,
+ implementation : is_atom_or_var_Op,
+ message :
+"Type which succeeds for an atom or a variable."
+ ).
+
+is_atom_or_var_Op(X) :-
+ atom(X),
+ !.
+is_atom_or_var_Op(X) :-
+ var(X).
+
+/*
+ * IS-STRING-OR-VAR
+ */
+opium_type(
+ name : is_string_or_var,
+ implementation : is_string_or_var_Op,
+ message :
+"Type which succeeds if its argument is a string or a variable.").
+is_string_or_var_Op(X) :-
+ var(X), !
+ ;
+ string(X).
+
+/*
+ * IS-STRING-OR-INTEGER-OR-VAR
+ */
+opium_type(
+ name : is_string_or_integer_or_var,
+ implementation : is_string_or_integer_or_var_Op,
+ message :
+"Type which succeeds if its argument is a string or a variable.").
+is_string_or_integer_or_var_Op(X) :-
+ var(X), !
+ ;
+ string(X), !
+ ;
+ integer(X).
+
+/*
+ * IS-STRING-OR-INTEGER
+ */
+opium_type(
+ name : is_string_or_integer,
+ implementation : is_string_or_integer_Op,
+ message :
+"Type which succeeds if its argument is a string or an integer.\n\
+").
+is_string_or_integer_Op(X) :-
+ integer(X), !
+ ;
+ string(X).
+
+
+/*
+ * IS-LIST-OR-VAR
+ */
+opium_type(
+ name : is_list_or_var,
+ implementation : is_list_or_var_Op,
+ message :
+"Type which succeeds for a list or a variable."
+ ).
+
+is_list_or_var_Op(L) :-
+ var(L),
+ !.
+is_list_or_var_Op(L) :-
+ is_list(L).
+
+
+/*
+ * IS-LIST-OF-ATOMS
+ */
+opium_type(
+ name : is_list_of_atoms,
+ implementation : is_list_of_atoms_Op,
+ message :
+"Type which succeeds for a list of atoms."
+ ).
+
+is_list_of_atoms_Op([A]) :-
+ atom(A),
+ !.
+is_list_of_atoms_Op([A|As]) :-
+ atom(A),
+ is_list_of_atoms_Op(As).
+
+
+/*
+ * IS-ATOM-OR-LIST-OF-ATOMS
+ */
+opium_type(
+ name : is_atom_or_list_of_atoms,
+ implementation : is_atom_or_list_of_atoms_Op,
+ message :
+"Type which succeeds for a single atom or a non-empty list of atoms."
+ ).
+
+is_atom_or_list_of_atoms_Op(X) :-
+ atom(X),
+ !.
+is_atom_or_list_of_atoms_Op(X) :-
+ is_list_of_atoms(X).
+
+
+/*
+ * IS-LIST-OF-PREDS
+ */
+opium_type(
+ name : is_list_of_preds,
+ implementation : is_list_of_preds_Op,
+ message :
+"Type which succeeds for a list of predicate ids of the form P/A or M:P/A. \n\
+The default module is the toplevel module in the traced session."
+ ).
+
+is_list_of_preds_Op([]).
+is_list_of_preds_Op([P|Ps]) :-
+ is_pred(P),
+ is_list_of_preds_Op(Ps).
+
+
+/*
+ * IS-PRED-OR-LIST-OF-PREDS
+ */
+opium_type(
+ name : is_pred_or_list_of_preds,
+ implementation : is_pred_or_list_of_preds_Op,
+ message :
+"Type which succeeds for a predicate id, or for a list of predicate ids of \n\
+the form P/A or M:P/A."
+ ).
+
+is_pred_or_list_of_preds_Op([]).
+is_pred_or_list_of_preds_Op([P|Ps]) :-
+ !,
+ is_pred(P),
+ is_pred_or_list_of_preds_Op(Ps).
+is_pred_or_list_of_preds_Op(P) :-
+ is_pred(P).
+
+
+/*
+ * IS-LIST-OF-INTEGERS
+ */
+opium_type(
+ name : is_list_of_integers,
+ implementation : is_list_of_integers_Op,
+ message :
+"Type which succeeds for a list of integers."
+ ).
+
+is_list_of_integers_Op([]).
+is_list_of_integers_Op([X|T]) :-
+ integer(X),
+ is_list_of_integers_Op(T).
+
+
+/*
+ * IS-LIST-OF-INTEGERS-OR-VAR
+ */
+opium_type(
+ name : is_list_of_integers_or_var,
+ implementation : is_list_of_integers_or_var_Op,
+ message :
+"Type which succeeds for a list of integers or a variable."
+ ).
+
+is_list_of_integers_or_var_Op(X) :-
+ var(X),
+ !.
+is_list_of_integers_or_var_Op(L) :-
+ is_list_of_integers(L).
+
+
+
+
+
Index: extras/opium_m/source/util.pl
===================================================================
RCS file: util.pl
diff -N util.pl
--- /dev/null Wed May 28 10:49:58 1997
+++ util.pl Tue Oct 26 23:26:45 1999
@@ -0,0 +1,249 @@
+%------------------------------------------------------------------------------%
+% Copyright (C) 1999 IRISA/INRIA.
+%
+% Authors : Erwan Jahier <jahier at irisa.fr>,
+% Mireille Ducassé <ducasse at irisa.fr>
+%
+% This file is compiled from make_scenario.pl and load_scenario.pl
+
+
+% to avoid seeing the singleton variable checkings
+:- set_flag(variable_names, on).
+
+:- import set_opium_level/1 from sepia_kernel.
+
+:- get_flag(prolog_suffix, S), set_flag(prolog_suffix, [".op" | S]).
+
+% to initialize module 'Opium-M'
+
+:- op(500, fx, =).
+:- op(500, fx, <).
+:- op(500, fx, =<).
+:- op(500, fx, >).
+:- op(500, fx, >=).
+
+:- dynamic opium_command/10.
+:- dynamic opium_parameter/8.
+:- dynamic opium_primitive/7.
+:- dynamic opium_procedure/6.
+:- dynamic opium_scenario/6.
+:- dynamic opium_type/4.
+:- dynamic opium_demo/5.
+:- dynamic autoload_command/2.
+:- dynamic autoload_scenario/4.
+
+:- dynamic opium_command/9.
+:- dynamic opium_parameter/6.
+:- dynamic opium_primitive/6.
+:- dynamic opium_procedure/5.
+:- dynamic opium_scenario/4.
+:- dynamic opium_type/3.
+:- dynamic opium_demo/3.
+:- dynamic autoload_command/2.
+:- dynamic autoload_scenario/4.
+
+
+opium_module.
+
+
+/* mandatory for bootstrapping */
+
+/* to avoid that file is dumped in compiled query
+ */
+
+mycompile(F) :-
+ compile(F).
+
+
+
+
+/*
+ * link commands/procedures to implementations to enable the bootstrapping
+ * before the scenario handler links together commands/procedures and their
+ * implementations
+ */
+
+make(S, MOD, OL, SD, OD) :- make_scenario_Op(S, MOD, OL, SD, OD).
+opium_scenario_in_module(S, M) :- opium_scenario_in_module_Op(S, M).
+set_default_parameters_in_module(S, Mod) :- set_default_parameters_in_module_Op(S, Mod).
+check_arg_type(X, Y, Z, T, M) :- check_arg_type_Op(X, Y, Z, T, M).
+check_arg(X, Y, Z, T, M) :- check_arg_Op(X, Y, Z, T, M).
+modify_time(F, T) :- modify_time_Op(F, T).
+
+is_list(X) :- is_list_Op(X).
+is_list_of_atoms(X) :- is_list_of_atoms_Op(X).
+is_list_of_atoms_or_empty_list(X) :- is_list_of_atoms_or_empty_list_Op(X).
+is_list_of_vars_or_empty_list(X) :- is_list_of_vars_or_empty_list_Op(X).
+is_list_of_ports(X) :- is_list_of_ports_Op(X).
+is_opium_declaration(P/A) :- is_opium_declaration_Op(P/A).
+is_opium_module(M) :- is_opium_module_Op(M).
+opium_module(M) :- opium_module_Op(M).
+
+% interface_status(X) :- interface_status_Op(X).
+
+opium_write(V, M) :- opium_write_Op(V, M).
+opium_printf(V, F, A) :- opium_printf_Op(V, F, A).
+opium_printf(V, F, A, S) :- opium_printf_Op(V, F, A, S).
+opium_nl(V) :- opium_nl_Op(V).
+
+
+get_opium_file("opium_module", File) :-
+ getenv('MERCURY_OPIUM_DIR', Path),
+ append_strings(Path, "source/opium_module.sd", File).
+
+
+/*
+ * sprintf/3
+ * the formatted string is converted to an atom an
+ * instantiated to the first parameter
+ */
+sprintf(Atom, Format, List) :-
+ open(_, string, Stream),
+ printf(Stream, Format, List),
+ current_stream(String, _, Stream),
+ atom_string(Atom, String),
+ close(Stream).
+
+/*
+ * namevar/2
+ * returns the name of a sepia variable as atom
+ */
+namevar(V, VN) :-
+ var(V),
+ open(_, string, Stream),
+ printf(Stream, "%QDw", [V]),
+ current_stream(S, _, Stream),
+ atom_string(VN, S),
+ close(Stream).
+
+opium_level(0).
+
+build_obj_dir(OD) :-
+ getcwd(Cwd),
+ append_strings(Cwd, "opiumfiles/", ODS),
+ atom_string(OD, ODS).
+
+
+% To be able to read Mercury terms, we need to set the associativities and
+% precedences according to what is done in Mercury (taken from
+% mercury/library/ops.m).
+set_mercury_assoc :-
+ op(1025, xfy, '&'), % Mercury extension
+ op(1179, xfy, '--->'), % Mercury extension
+ op(600, yfx, ':'), % `xfy' in ISO Prolog
+ op(1175, xfx, '::'), % Mercury extension
+ op(920, xfy, '<='), % Mercury/NU-Prolog extension
+ op(920, xfy, '<=>'), % Mercury/NU-Prolog extension
+ op(920, xfy, '=>'), % Mercury/NU-Prolog extension
+ % XXX produce an `out of range' Error in Eclipse.
+ % op(950, fxy, 'all'), % Mercury/NU-Prolog extension
+ op(1170, xfy, 'else'), % Mercury/NU-Prolog extension
+ op(1199, fx, 'end_module'), % Mercury extension
+ op(1199, fx, 'export_adt'), % Mercury extension (NYI)
+ op(1199, fx, 'export_cons'), % Mercury extension (NYI)
+ op(1199, fx, 'export_module'), % Mercury extension (NYI)
+ op(1199, fx, 'export_op'), % Mercury extension (NYI)
+ op(1199, fx, 'export_pred'), % Mercury extension (NYI)
+ op(1199, fx, 'export_sym'), % Mercury extension (NYI)
+ op(1199, fx, 'export_type'), % Mercury extension (NYI)
+ op(800, fx, 'func'), % Mercury extension
+ op(1160, fx, 'if'), % Mercury/NU-Prolog extension
+ op(1199, fx, 'import_adt'), % Mercury extension (NYI)
+ op(1199, fx, 'import_cons'), % Mercury extension (NYI)
+ op(1199, fx, 'import_module'), % Mercury extension
+ op(1199, fx, 'include_module'), % Mercury extension
+ op(1199, fx, 'import_op'), % Mercury extension (NYI)
+ op(1199, fx, 'import_pred'), % Mercury extension (NYI)
+ op(1199, fx, 'import_sym'), % Mercury extension (NYI)
+ op(1199, fx, 'import_type'), % Mercury extension (NYI)
+ op(800, fy, 'impure'), % Mercury extension
+ op(1199, fx, 'inst'), % Mercury extension
+ op(1199, fx, 'instance'), % Mercury extension
+ op(701, xfx, 'is'), % ISO Prolog says prec 700
+ % XXX produce an `out of range' Error in Eclipse.
+ % op(950, fxy, 'lambda'), % Mercury extension
+ op(1199, fx, 'mode'), % Mercury extension
+ op(1199, fx, 'module'), % Mercury extension
+ op(900, fy, 'not'), % Mercury/NU-Prolog extension
+ op(800, fx, 'pragma'), % Mercury extension
+ op(800, fx, 'pred'), % Mercury/NU-Prolog extension
+ op(800, fy, 'semipure'), % Mercury extension
+ % XXX produce an `out of range' Error in Eclipse.
+ % op(950, fxy, 'some'), % Mercury/NU-Prolog extension
+ op(1150, xfx, 'then'), % Mercury/NU-Prolog extension
+ op(1180, fx, 'type'), % Mercury extension
+ op(1199, fx, 'typeclass'), % Mercury extension
+ op(1199, fx, 'use_adt'), % Mercury extension (NYI)
+ op(1199, fx, 'use_cons'), % Mercury extension (NYI)
+ op(1199, fx, 'use_module'), % Mercury extension (NYI)
+ op(1199, fx, 'use_op'), % Mercury extension (NYI)
+ op(1199, fx, 'use_pred'), % Mercury extension (NYI)
+ op(1199, fx, 'use_sym'), % Mercury extension (NYI)
+ op(1199, fx, 'use_type'). % Mercury extension (NYI)
+
+reset_mercury_assoc :-
+ abolish_op('&', xfy), % Mercury extension
+ abolish_op('--->', xfy), % Mercury extension
+ abolish_op(':', yfx), % `xfy' in ISO Prolog
+ abolish_op('::', xfx), % Mercury extension
+ abolish_op('<=', xfy), % Mercury/NU-Prolog extension
+ abolish_op('<=>', xfy), % Mercury/NU-Prolog extension
+ abolish_op('=>', xfy), % Mercury/NU-Prolog extension
+ %abolish_op('all', fxy), % Mercury/NU-Prolog extension
+ abolish_op('else', xfy), % Mercury/NU-Prolog extension
+ abolish_op('end_module', fx), % Mercury extension
+ abolish_op('export_adt', fx), % Mercury extension (NYI)
+ abolish_op('export_cons', fx), % Mercury extension (NYI)
+ abolish_op('export_module', fx),% Mercury extension (NYI)
+ abolish_op('export_op', fx), % Mercury extension (NYI)
+ abolish_op('export_pred', fx), % Mercury extension (NYI)
+ abolish_op('export_sym', fx), % Mercury extension (NYI)
+ abolish_op('export_type', fx), % Mercury extension (NYI)
+ abolish_op('func', fx), % Mercury extension
+ abolish_op('if', fx), % Mercury/NU-Prolog extension
+ abolish_op('import_adt', fx), % Mercury extension (NYI)
+ abolish_op('import_cons', fx), % Mercury extension (NYI)
+ abolish_op('import_module', fx),% Mercury extension
+ abolish_op('include_module', fx),% Mercury extension
+ abolish_op('import_op', fx), % Mercury extension (NYI)
+ abolish_op('import_pred', fx), % Mercury extension (NYI)
+ abolish_op('import_sym', fx), % Mercury extension (NYI)
+ abolish_op('import_type', fx), % Mercury extension (NYI)
+ abolish_op('impure', fy), % Mercury extension
+ abolish_op('inst', fx), % Mercury extension
+ abolish_op('instance', fx), % Mercury extension
+ abolish_op('is', xfx), % ISO Prolog says prec 700
+ %abolish_op('lambda', fxy), % Mercury extension
+ abolish_op('mode', fx), % Mercury extension
+ abolish_op('module', fx), % Mercury extension
+ abolish_op('not', fy), % Mercury/NU-Prolog extension
+ abolish_op('pragma', fx), % Mercury extension
+ abolish_op('pred', fx), % Mercury/NU-Prolog extension
+ abolish_op('semipure', fy), % Mercury extension
+ %abolish_op('some', fxy), % Mercury/NU-Prolog extension
+ abolish_op('then', xfx), % Mercury/NU-Prolog extension
+ abolish_op('type', fx), % Mercury extension
+ abolish_op('typeclass', fx), % Mercury extension
+ abolish_op('use_adt', fx), % Mercury extension (NYI)
+ abolish_op('use_cons', fx), % Mercury extension (NYI)
+ abolish_op('use_module', fx), % Mercury extension (NYI)
+ abolish_op('use_op', fx), % Mercury extension (NYI)
+ abolish_op('use_pred', fx), % Mercury extension (NYI)
+ abolish_op('use_sym', fx), % Mercury extension (NYI)
+ abolish_op('use_type', fx). % Mercury extension (NYI)
+
+
+read_mercury_term(S, Term) :-
+ set_mercury_assoc,
+ read(S, Term),
+ reset_mercury_assoc.
+
+read_mercury_term(Term) :-
+ set_mercury_assoc,
+ read(Term),
+ reset_mercury_assoc.
+
+write_mercury_term(Term) :-
+ set_mercury_assoc,
+ write(Term),
+ reset_mercury_assoc.
--
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