[m-rev.] for review by Mark: impure function attributes

Zoltan Somogyi zs at csse.unimelb.edu.au
Fri Apr 27 18:05:58 AEST 2007


I haven't bootchecked it yet, but it works on the test case.

Zoltan.

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.

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 -b -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
-                            ),
+                                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 -b -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 -b -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 -b -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 -b -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.
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 07:53:41 -0000
@@ -0,0 +1,64 @@
+      E1:     C1 CALL pred synth_attr_impure.main/2-0 (cc_multi) synth_attr_impure.m:19
+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:35
+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:96
+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_96
+       list_sort_func (attr 6)	lambda2_synth_attr_impure_m_96
+       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:35
+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 -b -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 -b -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 -b -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 -b -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