[m-rev.] diff: ordinary_despite_detism

[Zoltan Somogyi]

Provide a mechanism for working around a problem with the Java implementation
of the nondet and multi modes of catch_impl in exception.m. The workaround
is not intended to be a long term solution.

compiler/ml_code_gen.m:
	Allow ordinary foreign_procs for nondet and multi procedures
	if they have the new foreign_proc attribute ordinary_despite_detism.

compiler/prog_data.m:
	Add the new attribute.

compiler/prog_io_pragma.m:
	Parse the new attribute.

Zoltan.

cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.142
diff -u -b -r1.142 ml_code_gen.m
--- compiler/ml_code_gen.m	17 Jun 2004 04:17:52 -0000	1.142
+++ compiler/ml_code_gen.m	2 Jul 2004 04:46:29 -0000
@@ -2386,8 +2386,15 @@
 		)
 	;
 		CodeModel = model_non,
+		OrdinaryDespiteDetism = ordinary_despite_detism(Attributes),
+		(
+			OrdinaryDespiteDetism = no,
 		error("ml_gen_ordinary_pragma_foreign_proc: " ++
 			"unexpected code model")
+		;
+			OrdinaryDespiteDetism = yes,
+			OrdinaryKind = kind_semi
+		)
 	),
 	(
 		Lang = c,
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.111
diff -u -b -r1.111 prog_data.m
--- compiler/prog_data.m	28 Jun 2004 04:49:45 -0000	1.111
+++ compiler/prog_data.m	2 Jul 2004 04:45:28 -0000
@@ -860,9 +860,10 @@
 :- func thread_safe(pragma_foreign_proc_attributes) = thread_safe.
 :- func purity(pragma_foreign_proc_attributes) = purity.
 :- func terminates(pragma_foreign_proc_attributes) = terminates.
-:- func legacy_purity_behaviour(pragma_foreign_proc_attributes) = bool.
 :- func foreign_language(pragma_foreign_proc_attributes) = foreign_language.
 :- func tabled_for_io(pragma_foreign_proc_attributes) = tabled_for_io.
+:- func legacy_purity_behaviour(pragma_foreign_proc_attributes) = bool.
+:- func ordinary_despite_detism(pragma_foreign_proc_attributes) = bool.
 :- func extra_attributes(pragma_foreign_proc_attributes)
 	= pragma_foreign_proc_extra_attributes.
 
@@ -894,6 +895,10 @@
 	pragma_foreign_proc_attributes::in,
 	pragma_foreign_proc_attributes::out) is det.
 
+:- pred set_ordinary_despite_detism(bool::in,
+	pragma_foreign_proc_attributes::in,
+	pragma_foreign_proc_attributes::out) is det.
+
 :- pred add_extra_attribute(pragma_foreign_proc_extra_attribute::in,
 	pragma_foreign_proc_attributes::in,
 	pragma_foreign_proc_attributes::out) is det.
@@ -1580,13 +1585,15 @@
 				% pragma c_code and pragma import purity
 				% if legacy_purity_behaviour is `yes'
 			legacy_purity_behaviour	:: bool,
+			ordinary_despite_detism	:: bool,
 			extra_attributes	::
 				list(pragma_foreign_proc_extra_attribute)
 		).
 
 default_attributes(Language) =
 	attributes(Language, may_call_mercury, not_thread_safe,
-		not_tabled_for_io, impure, depends_on_mercury_calls, no, []).
+		not_tabled_for_io, impure, depends_on_mercury_calls,
+		no, no, []).
 
 set_may_call_mercury(MayCallMercury, Attrs0, Attrs) :-
 	Attrs = Attrs0 ^ may_call_mercury := MayCallMercury.
@@ -1602,13 +1609,16 @@
 	Attrs = Attrs0 ^ terminates := Terminates.
 set_legacy_purity_behaviour(Legacy, Attrs0, Attrs) :-
 	Attrs = Attrs0 ^ legacy_purity_behaviour := Legacy.
+set_ordinary_despite_detism(OrdinaryDespiteDetism, Attrs0, Attrs) :-
+	Attrs = Attrs0 ^ ordinary_despite_detism := OrdinaryDespiteDetism.
 
 attributes_to_strings(Attrs) = StringList :-
 	% We ignore Lang because it isn't an attribute that you can put
 	% in the attribute list -- the foreign language specifier string
 	% is at the start of the pragma.
 	Attrs = attributes(_Lang, MayCallMercury, ThreadSafe, TabledForIO,
-			Purity,	Terminates, _LegacyBehaviour, ExtraAttributes),
+		Purity,	Terminates, _LegacyBehaviour, OrdinaryDespiteDetism,
+		ExtraAttributes),
 	(
 		MayCallMercury = may_call_mercury,
 		MayCallMercuryStr = "may_call_mercury"
@@ -1656,8 +1666,16 @@
 		Terminates = depends_on_mercury_calls,
 		TerminatesStrList = []
 	),
+	(
+		OrdinaryDespiteDetism = yes,
+		OrdinaryDespiteDetismStrList = ["ordinary_despite_detism"]
+	;
+		OrdinaryDespiteDetism = no,
+		OrdinaryDespiteDetismStrList = []
+	),
 	StringList = [MayCallMercuryStr, ThreadSafeStr, TabledForIOStr |
 			PurityStrList] ++ TerminatesStrList ++
+			OrdinaryDespiteDetismStrList ++
 		list__map(extra_attribute_to_string, ExtraAttributes).
 
 add_extra_attribute(NewAttribute, Attributes0,
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.69
diff -u -b -r1.69 prog_io_pragma.m
--- compiler/prog_io_pragma.m	28 Jun 2004 04:49:46 -0000	1.69
+++ compiler/prog_io_pragma.m	2 Jul 2004 04:41:43 -0000
@@ -1297,11 +1297,12 @@
 	;	purity(purity)
 	;	aliasing
 	;	max_stack_size(int)
-	;	terminates(terminates).
+	;	terminates(terminates)
+	;	ordinary_despite_detism.
 
-:- pred parse_pragma_foreign_proc_attributes_term(foreign_language, string,
-		term, maybe1(pragma_foreign_proc_attributes)).
-:- mode parse_pragma_foreign_proc_attributes_term(in, in, in, out) is det.
+:- pred parse_pragma_foreign_proc_attributes_term(foreign_language::in,
+	string::in, term::in, maybe1(pragma_foreign_proc_attributes)::out)
+	is det.
 
 parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, Term,
 		MaybeAttributes) :-
@@ -1347,7 +1348,8 @@
 			list__member(Conflict1, AttrList),
 			list__member(Conflict2, AttrList)
 		->
-			MaybeAttributes = error("conflicting attributes in attribute list", Term)
+			MaybeAttributes = error("conflicting attributes " ++
+				"in attribute list", Term)
 		;
 			list__foldl(
 				process_attribute,
@@ -1356,7 +1358,8 @@
 				ForeignLanguage, Attributes, Term)
 		)
 	;
-		ErrMsg = "expecting a foreign proc attribute or list of attributes",
+		ErrMsg = "expecting a foreign proc attribute " ++
+			"or list of attributes",
 		MaybeAttributes = error(ErrMsg, Term)
 	).
 
@@ -1378,6 +1381,8 @@
 	set_terminates(Terminates, !Attrs).
 process_attribute(max_stack_size(Size), !Attrs) :-
 	add_extra_attribute(max_stack_size(Size), !Attrs).
+process_attribute(ordinary_despite_detism, !Attrs) :-
+	set_ordinary_despite_detism(yes, !Attrs).
 
 	% Aliasing is currently ignored in the main branch compiler.
 process_attribute(aliasing, Attrs, Attrs).
@@ -1403,14 +1408,11 @@
 	).
 check_required_attributes(java, Attrs, _Term) = ok(Attrs).
 
-:- pred parse_pragma_foreign_proc_attributes_term0(term,
-		list(collected_pragma_foreign_proc_attribute)).
-:- mode parse_pragma_foreign_proc_attributes_term0(in, out) is semidet.
+:- pred parse_pragma_foreign_proc_attributes_term0(term::in,
+	list(collected_pragma_foreign_proc_attribute)::out) is semidet.
 
 parse_pragma_foreign_proc_attributes_term0(Term, Flags) :-
-	(
-		parse_single_pragma_foreign_proc_attribute(Term, Flag)
-	->
+	( parse_single_pragma_foreign_proc_attribute(Term, Flag) ->
 		Flags = [Flag]
 	;
 		(
@@ -1424,9 +1426,8 @@
 		)
 	).
 
-:- pred parse_single_pragma_foreign_proc_attribute(term,
-		collected_pragma_foreign_proc_attribute).
-:- mode parse_single_pragma_foreign_proc_attribute(in, out) is semidet.
+:- pred parse_single_pragma_foreign_proc_attribute(term::in,
+	collected_pragma_foreign_proc_attribute::out) is semidet.
 
 parse_single_pragma_foreign_proc_attribute(Term, Flag) :-
 	( parse_may_call_mercury(Term, MayCallMercury) ->
@@ -1443,12 +1444,13 @@
 		Flag = purity(Purity)
 	; parse_terminates(Term, Terminates) ->
 		Flag = terminates(Terminates)
+	; parse_ordinary_despite_detism(Term) ->
+		Flag = ordinary_despite_detism
 	;
 		fail
 	).
 
-:- pred parse_may_call_mercury(term, may_call_mercury).
-:- mode parse_may_call_mercury(in, out) is semidet.
+:- pred parse_may_call_mercury(term::in, may_call_mercury::out) is semidet.
 
 parse_may_call_mercury(term__functor(term__atom("recursive"), [], _),
 	may_call_mercury).
@@ -1459,16 +1461,14 @@
 parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [],
 	_), will_not_call_mercury).
 
-:- pred parse_threadsafe(term, thread_safe).
-:- mode parse_threadsafe(in, out) is semidet.
+:- pred parse_threadsafe(term::in, thread_safe::out) is semidet.
 
 parse_threadsafe(term__functor(term__atom("thread_safe"), [], _),
 	thread_safe).
 parse_threadsafe(term__functor(term__atom("not_thread_safe"), [], _),
 	not_thread_safe).
 
-:- pred parse_tabled_for_io(term, tabled_for_io).
-:- mode parse_tabled_for_io(in, out) is semidet.
+:- pred parse_tabled_for_io(term::in, tabled_for_io::out) is semidet.
 
 parse_tabled_for_io(term__functor(term__atom(Str), [], _), TabledForIo) :-
 	(
@@ -1489,8 +1489,7 @@
 	% These attributes are used for aliasing on the reuse branch,
 	% and ignoring them allows the main branch compiler to compile
 	% the reuse branch.
-:- pred parse_aliasing(term).
-:- mode parse_aliasing(in) is semidet.
+:- pred parse_aliasing(term::in) is semidet.
 
 parse_aliasing(term__functor(term__atom("no_aliasing"), [], _)).
 parse_aliasing(term__functor(term__atom("unknown_aliasing"), [], _)).
@@ -1516,16 +1515,22 @@
 parse_terminates(term__functor(term__atom("does_not_terminate"), [], _),
 		does_not_terminate).
 
+:- pred parse_ordinary_despite_detism(term::in) is semidet.
+
+parse_ordinary_despite_detism(
+		term__functor(term__atom("ordinary_despite_detism"), [], _)).
+
 % parse a pragma foreign_code declaration
 
-:- pred parse_pragma_foreign_code(module_name, pragma_foreign_proc_attributes,
-	term, pragma_foreign_code_impl, varset, maybe1(item)).
-:- mode parse_pragma_foreign_code(in, in, in, in, in, out) is det.
+:- pred parse_pragma_foreign_code(module_name::in,
+	pragma_foreign_proc_attributes::in, term::in,
+	pragma_foreign_code_impl::in, varset::in, maybe1(item)::out) is det.
 
 parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm0,
 	PragmaImpl, VarSet0, Result) :-
     parse_pred_or_func_and_args(yes(ModuleName), PredAndVarsTerm0,
-	PredAndVarsTerm0, "`:- pragma c_code' declaration", PredAndArgsResult),
+		PredAndVarsTerm0, "`:- pragma c_code' declaration",
+		PredAndArgsResult),
     (
 	PredAndArgsResult = ok(PredName, VarList0 - MaybeRetTerm),
 	(
@@ -1540,7 +1545,8 @@
 	    PredOrFunc = predicate,
 	    VarList = VarList0
 	),
-	parse_pragma_c_code_varlist(VarSet0, VarList, PragmaVars, Error),
+		parse_pragma_c_code_varlist(VarSet0, VarList, PragmaVars,
+			Error),
 	(
 	    Error = no,
 	    varset__coerce(VarSet0, VarSet),
@@ -1558,9 +1564,8 @@
 
 	% parse the variable list in the pragma c code declaration.
 	% The final argument is 'no' for no error, or 'yes(ErrorMessage)'.
-:- pred parse_pragma_c_code_varlist(varset, list(term),
-		list(pragma_var), maybe(string)).
-:- mode parse_pragma_c_code_varlist(in, in, out, out) is det.
+:- pred parse_pragma_c_code_varlist(varset::in, list(term)::in,
+	list(pragma_var)::out, maybe(string)::out) is det.
 
 parse_pragma_c_code_varlist(_, [], [], no).
 parse_pragma_c_code_varlist(VarSet, [V|Vars], PragmaVars, Error):-
@@ -1589,25 +1594,24 @@
 			% if the variable wasn't in the varset it must be an
 			% underscore variable.
 			PragmaVars = [],	% return any old junk for that.
-			Error = yes(
-"sorry, not implemented: anonymous `_' variable in pragma c_code")
+			Error = yes("sorry, not implemented: anonymous " ++
+				"`_' variable in pragma c_code")
 		)
 	;
 		PragmaVars = [],	% return any old junk in PragmaVars
 		Error = yes("arguments not in form 'Var :: mode'")
 	).
 
-:- pred parse_tabling_pragma(module_name, string, eval_method, list(term),
-		term, maybe1(item)).
-:- mode parse_tabling_pragma(in, in, in, in, in, out) is det.
+:- pred parse_tabling_pragma(module_name::in, string::in, eval_method::in,
+	list(term)::in, term::in, maybe1(item)::out) is det.
 
 parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms,
 		ErrorTerm, Result) :-
     (
         PragmaTerms = [PredAndModesTerm0]
     ->
-	string__append_list(["`:- pragma ", PragmaName, "' declaration"],
-		ParseMsg),
+		string__append_list(["`:- pragma ", PragmaName,
+			"' declaration"], ParseMsg),
 	parse_arity_or_modes(ModuleName, PredAndModesTerm0,
 		ErrorTerm, ParseMsg, ArityModesResult),
         (
@@ -1620,18 +1624,22 @@
 	    Result = error(Msg, Term)
 	)
     ;
-	string__append_list(["wrong number of arguments in `:- pragma ",
+		string__append_list(
+			["wrong number of arguments in `:- pragma ",
             PragmaName, "' declaration"], ErrorMessage),
         Result = error(ErrorMessage, ErrorTerm)
     ).
 
 :- type arity_or_modes
-	--->	arity_or_modes(sym_name, arity,
-			maybe(pred_or_func), maybe(list(mode))).
+	--->	arity_or_modes(
+			sym_name,
+			arity,
+			maybe(pred_or_func),
+			maybe(list(mode))
+		).
 
-:- pred parse_arity_or_modes(module_name, term, term,
-		string, maybe1(arity_or_modes)).
-:- mode parse_arity_or_modes(in, in, in, in, out) is det.
+:- pred parse_arity_or_modes(module_name::in, term::in, term::in,
+	string::in, maybe1(arity_or_modes)::out) is det.
 
 parse_arity_or_modes(ModuleName, PredAndModesTerm0,
 		ErrorTerm, ErrorMsg, Result) :-
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------