[m-rev.] for review: impure functions as user event attributes
Zoltan Somogyi
zs at csse.unimelb.edu.au
Tue May 1 16:28:55 AEST 2007
Implement impure functions as attributes of user events.
trace/mercury_event_spec.[ch]:
Allow the representation of such attributes in C code, and add the code
to write out such attributes.
trace/mercury_event_scanner.l:
trace/mercury_event_parser.y:
Implement the scanning and parsing of such attributes.
compiler/prog_event.m:
Modify the type of the terms generated by trace/mercury_event_spec.c
to include a pure/impure indication for function attributes.
Take this into account when generating the types of function
attributes.
Simplify some code by eliminating a redundant lookup in a map.
tests/debugger/synth_attr.{m,exp}:
Convert this line to four-space indentation, and update the expected
output to reflect the vim mode line at the top.
tests/debugger/synth_attr_impure.{m,inp,exp}:
tests/debugger/synth_attr_impure_spec:
New test case (a modified version of the synth_attr test case)
to test the new functionality.
tests/debugger/Mercury.options:
tests/debugger/Mmakefile:
Enable the new test case.
In the Mmakefile, delete some redundant 2>&1 constructs that were
apparantly created by careless cut-and-paste.
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/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/prog_event.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_event.m,v
retrieving revision 1.11
diff -u -r1.11 prog_event.m
--- compiler/prog_event.m 4 Apr 2007 01:09:44 -0000 1.11
+++ compiler/prog_event.m 27 Apr 2007 07:49:57 -0000
@@ -302,6 +302,10 @@
arg_attr_names :: list(string)
).
+:- type event_attr_function_kind
+ ---> event_attr_pure_function
+ ; event_attr_impure_function.
+
:- type event_attr_type
---> event_attr_type_ordinary(
event_attr_type_term
@@ -310,7 +314,9 @@
event_attr_type_term,
event_attr_synth_call_term
)
- ; event_attr_type_function.
+ ; event_attr_type_function(
+ event_attr_function_kind
+ ).
:- type event_attr_type_term
---> event_attr_type_term(
@@ -405,7 +411,7 @@
map.lookup(AttrMap, AttrName, attr_info(AttrNum, _, _, AttrType)),
(
( AttrType = event_attr_type_ordinary(_)
- ; AttrType = event_attr_type_function
+ ; AttrType = event_attr_type_function(_)
),
SynthAttrNums = SynthAttrNumsTail
;
@@ -482,7 +488,7 @@
svmap.det_insert(AttrName, Type, !AttrTypeMap)
)
;
- AttrTypeTerm = event_attr_type_function
+ AttrTypeTerm = event_attr_type_function(_)
),
build_plain_type_map(EventName, FileName, EventLineNumber, AttrTerms,
AttrNum + 1, !AttrNumMap, !AttrNameMap, !AttrTypeMap, !KeyMap, !DepRel,
@@ -516,13 +522,21 @@
AttrErrorSpecs = [],
( map.search(!.AttrTypeMap, AttrName, AttrType) ->
ArgTypes = list.map(map.lookup(!.AttrTypeMap), ArgAttrNames),
- FuncAttrType = higher_order_type(ArgTypes, yes(AttrType),
- purity_pure, lambda_normal),
(
- map.search(AttrNameMap, FuncAttrName, AttrInfo),
- AttrInfo ^ attr_info_type = event_attr_type_function
+ map.search(AttrNameMap, FuncAttrName, FuncAttrInfo),
+ FuncAttrInfo ^ attr_info_type =
+ event_attr_type_function(FuncAttrPurity)
->
(
+ FuncAttrPurity = event_attr_pure_function,
+ FuncPurity = purity_pure
+ ;
+ FuncAttrPurity = event_attr_impure_function,
+ FuncPurity = purity_impure
+ ),
+ FuncAttrType = higher_order_type(ArgTypes, yes(AttrType),
+ FuncPurity, lambda_normal),
+ (
map.search(!.AttrTypeMap, FuncAttrName,
OldFuncAttrType)
->
@@ -530,16 +544,8 @@
% AttrTypeMap already contains the correct info.
true
;
- (
- map.search(AttrNameMap, FuncAttrName,
- FuncAttrInfo)
- ->
- FuncAttrLineNumber =
- FuncAttrInfo ^ attr_info_linenumber
- ;
- % This is the best line number we can give,
- FuncAttrLineNumber = AttrLineNumber
- ),
+ FuncAttrLineNumber =
+ FuncAttrInfo ^ attr_info_linenumber,
% XXX Maybe we should give the types themselves.
Pieces = [words("Attribute"), quote(FuncAttrName),
words("is assigned inconsistent types"),
@@ -574,7 +580,7 @@
;
AttrTypeTerm = event_attr_type_ordinary(_TypeTerm)
;
- AttrTypeTerm = event_attr_type_function
+ AttrTypeTerm = event_attr_type_function(_)
),
build_dep_map(EventName, FileName, AttrNameMap, KeyMap, AttrTerms,
!AttrTypeMap, !DepRel, !ErrorSpecs).
@@ -645,7 +651,7 @@
true
)
;
- AttrTypeTerm = event_attr_type_function,
+ AttrTypeTerm = event_attr_type_function(_),
( map.search(AttrTypeMap, AttrName, AttrType) ->
EventAttr = event_attribute(AttrNum, AttrName, AttrType, in_mode,
no),
@@ -694,7 +700,7 @@
AttrTerm = AttrInfo ^ attr_info_type,
(
( AttrTerm = event_attr_type_ordinary(_)
- ; AttrTerm = event_attr_type_function
+ ; AttrTerm = event_attr_type_function(_)
),
PrevSynthOrder = []
;
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
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/fixed
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
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/log4m
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/mopenssl
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/net
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/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
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/c_interface/standalone_c
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
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 slice
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
Index: tests/debugger/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/Mercury.options,v
retrieving revision 1.22
diff -u -r1.22 Mercury.options
--- tests/debugger/Mercury.options 23 Feb 2007 06:35:55 -0000 1.22
+++ tests/debugger/Mercury.options 27 Apr 2007 07:26:09 -0000
@@ -48,6 +48,7 @@
MCFLAGS-user_event_2 = --event-set-file-name user_event_spec_2
MCFLAGS-synth_attr = --event-set-file-name synth_attr_spec
+MCFLAGS-synth_attr_impure = --event-set-file-name synth_attr_impure_spec
# The solver_test test case exercises the printing of a procedure name, and
# that procedure is dead, so we must prevent it being optimized away.
Index: tests/debugger/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/Mmakefile,v
retrieving revision 1.132
diff -u -r1.132 Mmakefile
--- tests/debugger/Mmakefile 19 Apr 2007 04:24:52 -0000 1.132
+++ tests/debugger/Mmakefile 27 Apr 2007 07:51:58 -0000
@@ -52,6 +52,7 @@
solver_test \
switch_on_unbounded \
synth_attr \
+ synth_attr_impure \
type_desc_test \
uci_index \
user_event \
@@ -541,24 +542,29 @@
> type_desc_test.out 2>&1
uci.out: uci uci.inp
- $(MDB) ./uci < uci.inp 2>&1 > uci.out 2>&1
+ $(MDB) ./uci < uci.inp > uci.out 2>&1
uci_index.out: uci_index uci_index.inp
- $(MDB_STD) ./uci_index < uci_index.inp 2>&1 > uci_index.out 2>&1
+ $(MDB_STD) ./uci_index < uci_index.inp > uci_index.out 2>&1
synth_attr.out: synth_attr synth_attr.inp synth_attr_spec
- $(MDB_STD) ./synth_attr < synth_attr.inp 2>&1 > synth_attr.out 2>&1
+ $(MDB_STD) ./synth_attr < synth_attr.inp > synth_attr.out 2>&1
+
+synth_attr_impure.out: synth_attr_impure synth_attr_impure.inp \
+ synth_attr_impure_spec
+ $(MDB_STD) ./synth_attr_impure < synth_attr_impure.inp \
+ > synth_attr_impure.out 2>&1
user_event.out: user_event user_event.inp user_event_spec
$(MDB_STD) ./user_event < user_event.inp 2>&1 > user_event.out 2>&1
user_event_2.out: user_event_2 user_event_2.inp user_event_spec_2
- $(MDB_STD) ./user_event_2 < user_event_2.inp 2>&1 \
+ $(MDB_STD) ./user_event_2 < user_event_2.inp \
> user_event_2.out 2>&1
user_event_shallow.out: user_event_shallow user_event_shallow.inp \
user_event_spec
- $(MDB_STD) ./user_event_shallow < user_event_shallow.inp 2>&1 \
+ $(MDB_STD) ./user_event_shallow < user_event_shallow.inp \
> user_event_shallow.out 2>&1
# When WORKSPACE is set, use $(WORKSPACE)/tools/lmc to compile the query.
Index: tests/debugger/synth_attr.exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/synth_attr.exp,v
retrieving revision 1.3
diff -u -r1.3 synth_attr.exp
--- tests/debugger/synth_attr.exp 26 Apr 2007 09:10:47 -0000 1.3
+++ tests/debugger/synth_attr.exp 27 Apr 2007 07:26:27 -0000
@@ -1,9 +1,9 @@
- E1: C1 CALL pred synth_attr.main/2-0 (cc_multi) synth_attr.m:17
+ E1: C1 CALL pred synth_attr.main/2-0 (cc_multi) synth_attr.m:19
mdb> echo on
Command echo enabled.
mdb> register --quiet
mdb> user
- E2: C2 USER <safe_test> pred synth_attr.queen/2-0 (nondet) c5; synth_attr.m:33
+ E2: C2 USER <safe_test> pred synth_attr.queen/2-0 (nondet) c5; synth_attr.m:35
mdb> print *
test_list (attr 0, Out) [1, 2, 3, 4, 5]
f (attr 1) testlen(10)
@@ -17,7 +17,7 @@
2
browser> quit
mdb> user
- E3: C3 USER <nodiag_fail> pred synth_attr.nodiag/3-0 (semidet) s2-2;c4;t;c4; synth_attr.m:75
+ E3: C3 USER <nodiag_fail> pred synth_attr.nodiag/3-0 (semidet) s2-2;c4;t;c4; synth_attr.m:77
mdb> vars
1 test_failed (attr 0)
2 arg_b (attr 1, B)
@@ -40,8 +40,8 @@
arg_d (attr 2, N) 2
arg_list_len (attr 3) 4
sorted_list (attr 4) [2, 3, 4, 5]
- list_len_func (attr 5) lambda_synth_attr_m_75
- list_sort_func (attr 6) lambda2_synth_attr_m_75
+ list_len_func (attr 5) lambda_synth_attr_m_77
+ list_sort_func (attr 6) lambda2_synth_attr_m_77
arg_list (attr 7, HeadVar__3) [2, 3, 4, 5]
D (arg 2) 1
BmN -1
@@ -50,7 +50,7 @@
mdb> print !arg_b
arg_b (attr 1, B) 1
mdb> user
- E4: C2 USER <safe_test> pred synth_attr.queen/2-0 (nondet) c5; synth_attr.m:33
+ E4: C2 USER <safe_test> pred synth_attr.queen/2-0 (nondet) c5; synth_attr.m:35
mdb> print *
test_list (attr 0, Out) [1, 2, 3, 5, 4]
f (attr 1) testlen(10)
Index: tests/debugger/synth_attr.m
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/synth_attr.m,v
retrieving revision 1.1
diff -u -r1.1 synth_attr.m
--- tests/debugger/synth_attr.m 14 Dec 2006 04:36:01 -0000 1.1
+++ tests/debugger/synth_attr.m 27 Apr 2007 07:21:26 -0000
@@ -1,3 +1,5 @@
+% vim: ts=4 sw=4 et
+
:- module synth_attr.
:- interface.
@@ -15,12 +17,12 @@
:- type listint == list(int).
main(!IO) :-
- data(Data),
- ( queen(Data, Out) ->
- print_list(Out, !IO)
- ;
- io.write_string("No solution\n", !IO)
- ).
+ data(Data),
+ ( queen(Data, Out) ->
+ print_list(Out, !IO)
+ ;
+ io.write_string("No solution\n", !IO)
+ ).
:- pred data(list(int)::out) is det.
@@ -29,84 +31,84 @@
:- pred queen(list(int)::in, list(int)::out) is nondet.
queen(Data, Out) :-
- qperm(Data, Out),
- event safe_test(Out, testlen(10)),
- safe(Out).
+ qperm(Data, Out),
+ event safe_test(Out, testlen(10)),
+ safe(Out).
:- func testlen(int, list(int)) = int.
testlen(Min, L) = N :-
- list.length(L, N0),
- ( N0 >= Min ->
- N = N0
- ;
- error("testlen: N < Min")
- ).
+ list.length(L, N0),
+ ( N0 >= Min ->
+ N = N0
+ ;
+ error("testlen: N < Min")
+ ).
:- pred qperm(list(T)::in, list(T)::out) is nondet.
qperm([], []).
qperm(L, K) :-
- L = [_ | _],
- qdelete(U, L, Z),
- K = [U | V],
- qperm(Z, V).
+ L = [_ | _],
+ qdelete(U, L, Z),
+ K = [U | V],
+ qperm(Z, V).
:- pred qdelete(T::out, list(T)::in, list(T)::out) is nondet.
qdelete(A, [A | L], L).
qdelete(X, [A | Z], [A | R]) :-
- qdelete(X, Z, R).
+ qdelete(X, Z, R).
:- pred safe(list(int)::in) is semidet.
safe([]).
safe([N | L]) :-
- nodiag(N, 1, L),
- safe(L).
+ nodiag(N, 1, L),
+ safe(L).
:- pred nodiag(int::in, int::in, list(int)::in) is semidet.
nodiag(_, _, []).
nodiag(B, D, [N | L]) :-
- NmB = N - B,
- BmN = B - N,
- ( D = NmB ->
- event nodiag_fail("N - B", B, N, list.length, list.sort,
- [N | L]),
- fail
- ; D = BmN ->
- event nodiag_fail("B - N", B, N, list.length, list.sort,
- [N | L]),
- fail
- ;
- true
- ),
- D1 = D + 1,
- nodiag(B, D1, L).
+ NmB = N - B,
+ BmN = B - N,
+ ( D = NmB ->
+ event nodiag_fail("N - B", B, N, list.length, list.sort,
+ [N | L]),
+ fail
+ ; D = BmN ->
+ event nodiag_fail("B - N", B, N, list.length, list.sort,
+ [N | L]),
+ fail
+ ;
+ true
+ ),
+ D1 = D + 1,
+ nodiag(B, D1, L).
:- pred print_list(list(int)::in, io::di, io::uo) is det.
print_list(Xs, !IO) :-
- (
- Xs = [],
- io.write_string("[]\n", !IO)
- ;
- Xs = [_ | _],
- io.write_string("[", !IO),
- print_list_2(Xs, !IO),
- io.write_string("]\n", !IO)
- ).
+ (
+ Xs = [],
+ io.write_string("[]\n", !IO)
+ ;
+ Xs = [_ | _],
+ io.write_string("[", !IO),
+ print_list_2(Xs, !IO),
+ io.write_string("]\n", !IO)
+ ).
:- pred print_list_2(list(int)::in, io::di, io::uo) is det.
print_list_2([], !IO).
print_list_2([X | Xs], !IO) :-
- io.write_int(X, !IO),
- (
- Xs = []
- ;
- Xs = [_ | _],
- io__write_string(", ", !IO),
- print_list_2(Xs, !IO)
- ).
+ io.write_int(X, !IO),
+ (
+ Xs = []
+ ;
+ Xs = [_ | _],
+ io__write_string(", ", !IO),
+ print_list_2(Xs, !IO)
+ ).
Index: tests/debugger/synth_attr_impure.exp
===================================================================
RCS file: tests/debugger/synth_attr_impure.exp
diff -N tests/debugger/synth_attr_impure.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/synth_attr_impure.exp 27 Apr 2007 12:10:55 -0000
@@ -0,0 +1,64 @@
+ E1: C1 CALL pred synth_attr_impure.main/2-0 (cc_multi) synth_attr_impure.m:28
+mdb> echo on
+Command echo enabled.
+mdb> register --quiet
+mdb> user
+ E2: C2 USER <safe_test> pred synth_attr_impure.queen/2-0 (nondet) c6; synth_attr_impure.m:44
+mdb> print *
+ test_list (attr 0, Out) [1, 2, 3, 4, 5]
+ f (attr 1) testlen(10)
+ excp (attr 2) univ_cons(software_error("testlen: N < Min"))
+ g (attr 3) safe_counter
+ seq (attr 4) 0
+ Data (arg 1) [1, 2, 3, 4, 5]
+mdb> browse !test_list
+browser> p
+[1, 2, 3, 4, 5]
+browser> ^2^1
+browser> p
+2
+browser> quit
+mdb> user
+ E3: C3 USER <nodiag_fail> pred synth_attr_impure.nodiag/3-0 (semidet) s2-2;c4;t;c4; synth_attr_impure.m:105
+mdb> vars
+ 1 test_failed (attr 0)
+ 2 arg_b (attr 1, B)
+ 3 arg_d (attr 2, N)
+ 4 arg_list_len (attr 3)
+ 5 sorted_list (attr 4)
+ 6 list_len_func (attr 5)
+ 7 list_sort_func (attr 6)
+ 8 arg_list (attr 7, HeadVar__3)
+ 9 B (arg 1)
+ 10 D (arg 2)
+ 11 HeadVar__3
+ 12 BmN
+ 13 L
+ 14 N
+ 15 NmB
+mdb> print *
+ test_failed (attr 0) "N - B"
+ arg_b (attr 1, B) 1
+ arg_d (attr 2, N) 2
+ arg_list_len (attr 3) 4
+ sorted_list (attr 4) [2, 3, 4, 5]
+ list_len_func (attr 5) lambda_synth_attr_impure_m_105
+ list_sort_func (attr 6) lambda2_synth_attr_impure_m_105
+ arg_list (attr 7, HeadVar__3) [2, 3, 4, 5]
+ D (arg 2) 1
+ BmN -1
+ L [3, 4, 5]
+ NmB 1
+mdb> print !arg_b
+ arg_b (attr 1, B) 1
+mdb> user
+ E4: C2 USER <safe_test> pred synth_attr_impure.queen/2-0 (nondet) c6; synth_attr_impure.m:44
+mdb> print *
+ test_list (attr 0, Out) [1, 2, 3, 5, 4]
+ f (attr 1) testlen(10)
+ excp (attr 2) univ_cons(software_error("testlen: N < Min"))
+ g (attr 3) safe_counter
+ seq (attr 4) 1
+ Data (arg 1) [1, 2, 3, 4, 5]
+mdb> continue
+[1, 3, 5, 2, 4]
Index: tests/debugger/synth_attr_impure.inp
===================================================================
RCS file: tests/debugger/synth_attr_impure.inp
diff -N tests/debugger/synth_attr_impure.inp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/synth_attr_impure.inp 27 Apr 2007 07:22:18 -0000
@@ -0,0 +1,16 @@
+echo on
+register --quiet
+user
+print *
+browse !test_list
+p
+^2^1
+p
+quit
+user
+vars
+print *
+print !arg_b
+user
+print *
+continue
Index: tests/debugger/synth_attr_impure.m
===================================================================
RCS file: tests/debugger/synth_attr_impure.m
diff -N tests/debugger/synth_attr_impure.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/synth_attr_impure.m 27 Apr 2007 07:57:30 -0000
@@ -0,0 +1,142 @@
+% vim: ts=4 sw=4 et ft=mercury
+%
+% This test case tests the handling of impure functions as attributes of user
+% events.
+%
+% In this test case, the impure function, safe_counter, records the number of
+% "safe" tests so far. Unfortunately, we cannot make safe_counter a zero arity
+% function, since any mention of such a function is automatically converted by
+% the compiler into an *invocation* of that function. This made sense when all
+% functions were pure, but doesn't make sense anymore.
+
+:- module synth_attr_impure.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+:- implementation.
+
+:- import_module list.
+:- import_module int.
+:- import_module require.
+
+:- type listint == list(int).
+
+main(!IO) :-
+ data(Data),
+ ( queen(Data, Out) ->
+ print_list(Out, !IO)
+ ;
+ io.write_string("No solution\n", !IO)
+ ).
+
+:- pred data(list(int)::out) is det.
+
+data([1,2,3,4,5]).
+
+:- pred queen(list(int)::in, list(int)::out) is nondet.
+
+queen(Data, Out) :-
+ qperm(Data, Out),
+ event safe_test(Out, testlen(10), safe_counter),
+ safe(Out).
+
+:- pragma foreign_decl("C",
+"
+extern int safe_counter;
+").
+
+:- pragma foreign_code("C",
+"
+int safe_counter = 0;
+").
+
+:- impure func safe_counter(list(int)) = int.
+
+:- pragma foreign_proc("C",
+ safe_counter(_Out::in) = (Seq::out),
+ [will_not_call_mercury],
+"
+ Seq = safe_counter++;
+").
+
+:- func testlen(int, list(int)) = int.
+
+testlen(Min, L) = N :-
+ list.length(L, N0),
+ ( N0 >= Min ->
+ N = N0
+ ;
+ error("testlen: N < Min")
+ ).
+
+:- pred qperm(list(T)::in, list(T)::out) is nondet.
+
+qperm([], []).
+qperm(L, K) :-
+ L = [_ | _],
+ qdelete(U, L, Z),
+ K = [U | V],
+ qperm(Z, V).
+
+:- pred qdelete(T::out, list(T)::in, list(T)::out) is nondet.
+
+qdelete(A, [A | L], L).
+qdelete(X, [A | Z], [A | R]) :-
+ qdelete(X, Z, R).
+
+:- pred safe(list(int)::in) is semidet.
+
+safe([]).
+safe([N | L]) :-
+ nodiag(N, 1, L),
+ safe(L).
+
+:- pred nodiag(int::in, int::in, list(int)::in) is semidet.
+
+nodiag(_, _, []).
+nodiag(B, D, [N | L]) :-
+ NmB = N - B,
+ BmN = B - N,
+ ( D = NmB ->
+ event nodiag_fail("N - B", B, N, list.length, list.sort,
+ [N | L]),
+ fail
+ ; D = BmN ->
+ event nodiag_fail("B - N", B, N, list.length, list.sort,
+ [N | L]),
+ fail
+ ;
+ true
+ ),
+ D1 = D + 1,
+ nodiag(B, D1, L).
+
+:- pred print_list(list(int)::in, io::di, io::uo) is det.
+
+print_list(Xs, !IO) :-
+ (
+ Xs = [],
+ io.write_string("[]\n", !IO)
+ ;
+ Xs = [_ | _],
+ io.write_string("[", !IO),
+ print_list_2(Xs, !IO),
+ io.write_string("]\n", !IO)
+ ).
+
+:- pred print_list_2(list(int)::in, io::di, io::uo) is det.
+
+print_list_2([], !IO).
+print_list_2([X | Xs], !IO) :-
+ io.write_int(X, !IO),
+ (
+ Xs = []
+ ;
+ Xs = [_ | _],
+ io__write_string(", ", !IO),
+ print_list_2(Xs, !IO)
+ ).
Index: tests/debugger/synth_attr_impure_spec
===================================================================
RCS file: tests/debugger/synth_attr_impure_spec
diff -N tests/debugger/synth_attr_impure_spec
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/synth_attr_impure_spec 27 Apr 2007 07:36:25 -0000
@@ -0,0 +1,20 @@
+event set queens
+
+event nodiag_fail(
+/* 0 */ test_failed: string,
+/* 1 */ arg_b: int,
+/* 2 */ arg_d: int,
+/* 3 */ arg_list_len: int synthesized by list_len_func(sorted_list),
+/* 4 */ sorted_list: list(int) synthesized by list_sort_func(arg_list),
+/* 5 */ list_len_func: function,
+/* 6 */ list_sort_func: function,
+/* 7 */ arg_list: list(int)
+)
+
+event safe_test(
+ test_list: listint,
+ f: function,
+ excp: int synthesized by f(test_list),
+ g: impure function,
+ seq: int synthesized by g(test_list)
+)
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/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
Index: trace/mercury_event_parser.y
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/trace/mercury_event_parser.y,v
retrieving revision 1.4
diff -u -r1.4 mercury_event_parser.y
--- trace/mercury_event_parser.y 11 Jan 2007 03:07:44 -0000 1.4
+++ trace/mercury_event_parser.y 27 Apr 2007 07:04:34 -0000
@@ -53,6 +53,7 @@
%token <Uline> TOKEN_EVENT
%token TOKEN_SET
+%token TOKEN_IMPURE
%token TOKEN_FUNCTION
%token TOKEN_SYNTHESIZED
%token TOKEN_BY
@@ -158,7 +159,14 @@
| TOKEN_FUNCTION
{
$$ = MR_NEW(struct MR_EventAttrType_Struct);
- $$->MR_type_kind = MR_EVENT_ATTR_FUNCTION;
+ $$->MR_type_kind = MR_EVENT_ATTR_PURE_FUNCTION;
+ $$->MR_type_term = NULL;
+ $$->MR_type_synth_call = NULL;
+ }
+ | TOKEN_IMPURE TOKEN_FUNCTION
+ {
+ $$ = MR_NEW(struct MR_EventAttrType_Struct);
+ $$->MR_type_kind = MR_EVENT_ATTR_IMPURE_FUNCTION;
$$->MR_type_term = NULL;
$$->MR_type_synth_call = NULL;
}
Index: trace/mercury_event_scanner.l
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/trace/mercury_event_scanner.l,v
retrieving revision 1.3
diff -u -r1.3 mercury_event_scanner.l
--- trace/mercury_event_scanner.l 14 Dec 2006 04:36:03 -0000 1.3
+++ trace/mercury_event_scanner.l 27 Apr 2007 07:05:08 -0000
@@ -99,6 +99,7 @@
return TOKEN_EVENT;
}
"set" { return TOKEN_SET; }
+"impure" { return TOKEN_IMPURE; }
"function" { return TOKEN_FUNCTION; }
"synthesized" { return TOKEN_SYNTHESIZED; }
"by" { return TOKEN_BY; }
Index: trace/mercury_event_spec.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/trace/mercury_event_spec.c,v
retrieving revision 1.4
diff -u -r1.4 mercury_event_spec.c
--- trace/mercury_event_spec.c 14 Dec 2006 04:36:03 -0000 1.4
+++ trace/mercury_event_spec.c 27 Apr 2007 07:08:05 -0000
@@ -182,8 +182,14 @@
fprintf(fp, ")");
break;
- case MR_EVENT_ATTR_FUNCTION:
- fprintf(fp, "event_attr_type_function");
+ case MR_EVENT_ATTR_PURE_FUNCTION:
+ fprintf(fp,
+ "event_attr_type_function(event_attr_pure_function)");
+ break;
+
+ case MR_EVENT_ATTR_IMPURE_FUNCTION:
+ fprintf(fp,
+ "event_attr_type_function(event_attr_impure_function)");
break;
case MR_EVENT_ATTR_SYNTHESIZED:
Index: trace/mercury_event_spec.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/trace/mercury_event_spec.h,v
retrieving revision 1.3
diff -u -r1.3 mercury_event_spec.h
--- trace/mercury_event_spec.h 14 Dec 2006 04:36:03 -0000 1.3
+++ trace/mercury_event_spec.h 27 Apr 2007 07:02:37 -0000
@@ -68,7 +68,8 @@
typedef enum {
MR_EVENT_ATTR_ORDINARY,
- MR_EVENT_ATTR_FUNCTION,
+ MR_EVENT_ATTR_PURE_FUNCTION,
+ MR_EVENT_ATTR_IMPURE_FUNCTION,
MR_EVENT_ATTR_SYNTHESIZED
} MR_EventAttrKind;
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 messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list