[m-rev.] for review: fix dummy type bug in construct.construct

Zoltan Somogyi zs at cs.mu.OZ.AU
Mon Nov 21 21:01:17 AEDT 2005


On 19-Nov-2005, Zoltan Somogyi <zs at cs.mu.OZ.AU> wrote:
> The fix is fine, and you can commit it. I have a more extensive fix
> that also tries to prevent such problems from happening again; I'll
> commit that after yours and after my bootcheck finishes.

Here it is.

Try to reduce the probability of any bug such as the one reported by
Peter Ross happening again.

library/construct.m:
	Make sure that the relevant switches list all the values of the enum
	type the switch is on, since this way gcc will generate a warning
	message if the enum has a value added to it and the switch isn't
	updated.

	Include the defaults only if MR_INCLUDE_SWITCH_DEFAULTS is defined;
	the intention is that this may be useful with non-gcc compilers.

	Generate separate, more specific error messages for each type_ctor_rep.

library/deconstruct.m:
	Delete some old code that we haven't used in a while, and which we
	won't want to use in the future either. (The deleted predicate worked
	on the data representation scheme of the running compiler, whereas
	we wanted it to work on the data representation scheme of the generated
	program, which may be different.)

	I found this when inspecting all uses of switch defaults in the
	library.

runtime/mercury_conf_params.h:
	Document MR_INCLUDE_SWITCH_DEFAULTS.

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
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/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/easyx
cvs diff: Diffing extras/graphics/easyx/samples
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/solver_types
cvs diff: Diffing extras/solver_types/library
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/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
Index: library/construct.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.24
diff -u -b -r1.24 construct.m
--- library/construct.m	20 Nov 2005 06:02:24 -0000	1.24
+++ library/construct.m	21 Nov 2005 06:55:55 -0000
@@ -315,10 +315,9 @@
     type_info = (MR_TypeInfo) TypeDesc;
 
         /*
-        ** Get information for this functor number and
-        ** store in construct_info. If this is a discriminated union
-        ** type and if the functor number is in range, we
-        ** succeed.
+    ** Get information for this functor number and store in construct_info.
+    ** If this is a discriminated union type and if the functor number is
+    ** in range, we succeed.
         */
     MR_save_transient_registers();
     success = MR_get_functors_check_range(FunctorNumber, type_info,
@@ -334,12 +333,12 @@
                 enum_functor_desc->MR_enum_functor_ordinal;
             break;
 
+        case MR_TYPECTOR_REP_DUMMY:
         case MR_TYPECTOR_REP_NOTAG:
         case MR_TYPECTOR_REP_NOTAG_USEREQ:
         case MR_TYPECTOR_REP_NOTAG_GROUND:
         case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
         case MR_TYPECTOR_REP_TUPLE:
-        case MR_TYPECTOR_REP_DUMMY:
             Ordinal = 0;
             break;
 
@@ -351,7 +350,38 @@
                 du_functor_desc->MR_du_functor_ordinal;
             break;
 
-        default:
+        case MR_TYPECTOR_REP_EQUIV:
+        case MR_TYPECTOR_REP_EQUIV_GROUND:
+        case MR_TYPECTOR_REP_FUNC:
+        case MR_TYPECTOR_REP_PRED:
+        case MR_TYPECTOR_REP_INT:
+        case MR_TYPECTOR_REP_FLOAT:
+        case MR_TYPECTOR_REP_CHAR:
+        case MR_TYPECTOR_REP_STRING:
+        case MR_TYPECTOR_REP_SUBGOAL:
+        case MR_TYPECTOR_REP_VOID:
+        case MR_TYPECTOR_REP_C_POINTER:
+        case MR_TYPECTOR_REP_STABLE_C_POINTER:
+        case MR_TYPECTOR_REP_TYPEINFO:
+        case MR_TYPECTOR_REP_TYPECTORINFO:
+        case MR_TYPECTOR_REP_TYPECLASSINFO:
+        case MR_TYPECTOR_REP_BASETYPECLASSINFO:
+        case MR_TYPECTOR_REP_TYPEDESC:
+        case MR_TYPECTOR_REP_TYPECTORDESC:
+        case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
+        case MR_TYPECTOR_REP_ARRAY:
+        case MR_TYPECTOR_REP_REFERENCE:
+        case MR_TYPECTOR_REP_SUCCIP:
+        case MR_TYPECTOR_REP_HP:
+        case MR_TYPECTOR_REP_CURFR:
+        case MR_TYPECTOR_REP_MAXFR:
+        case MR_TYPECTOR_REP_REDOFR:
+        case MR_TYPECTOR_REP_REDOIP:
+        case MR_TYPECTOR_REP_TRAIL_PTR:
+        case MR_TYPECTOR_REP_TICKET:
+        case MR_TYPECTOR_REP_FOREIGN:
+        case MR_TYPECTOR_REP_STABLE_FOREIGN:
+        case MR_TYPECTOR_REP_UNKNOWN:
             success = MR_FALSE;
 
         }
@@ -372,17 +402,12 @@
 
     type_info = (MR_TypeInfo) TypeDesc;
 
-        /*
-        ** If type_info is an equivalence type, expand it.
-        */
+    /* If type_info is an equivalence type, expand it. */
     MR_save_transient_registers();
     type_info = MR_collapse_equivalences(type_info);
     MR_restore_transient_registers();
 
-        /*
-        ** Check range of FunctorNum, get info for this
-        ** functor.
-        */
+    /* Check range of FunctorNum, get info for this functor. */
     MR_save_transient_registers();
     success =
         MR_get_functors_check_range(FunctorNumber, type_info, &construct_info)
@@ -390,14 +415,12 @@
             construct_info.arg_pseudo_type_infos);
     MR_restore_transient_registers();
 
-        /*
-        ** Build the new term in `new_data'.
-        */
+    /* Build the new term in `new_data'. */
     if (success) {
         type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
 
         if (MR_type_ctor_rep(type_ctor_info) != construct_info.type_ctor_rep) {
-            MR_fatal_error(""construct:construct: type_ctor_rep mismatch"");
+            MR_fatal_error(""construct.construct: type_ctor_rep mismatch"");
         }
 
         switch (MR_type_ctor_rep(type_ctor_info)) {
@@ -475,7 +498,7 @@
                 functor_desc = construct_info.functor_info.du_functor_desc;
                 if (functor_desc->MR_du_functor_exist_info != NULL) {
                     MR_fatal_error(""not yet implemented: construction ""
-                        ""of terms containing existentially types"");
+                        ""of terms containing existential types"");
                 }
 
                 arg_list = ArgList;
@@ -493,7 +516,7 @@
 
                     MR_tag_offset_incr_hp_msg(new_data, ptag,
                         MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1 + arity,
-                        MR_PROC_LABEL, ""<created by construct:construct/3>"");
+                        MR_PROC_LABEL, ""<created by construct.construct/3>"");
 
                     size = MR_cell_size(arity);
                     MR_field(ptag, new_data, 0) =
@@ -518,7 +541,7 @@
 
                     MR_tag_offset_incr_hp_msg(new_data, ptag,
                         MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + arity,
-                        MR_PROC_LABEL, ""<created by construct:construct/3>"");
+                        MR_PROC_LABEL, ""<created by construct.construct/3>"");
 
                     size = MR_cell_size(arity);
                     for (i = 0; i < arity; i++) {
@@ -540,13 +563,16 @@
                     new_data = (MR_Word) 0;     /* avoid a warning */
                     MR_fatal_error(""construct(): cannot construct variable"");
 
+#ifdef MR_INCLUDE_SWITCH_DEFAULTS
                 default:
                     new_data = (MR_Word) 0;     /* avoid a warning */
                     MR_fatal_error(""construct(): unrecognised sectag locn"");
+#endif
+
                 }
 
                 if (! MR_list_is_empty(arg_list)) {
-                    MR_fatal_error(""excess arguments in construct:construct"");
+                    MR_fatal_error(""excess arguments in construct.construct"");
                 }
             }
             break;
@@ -567,7 +593,7 @@
                 } else {
                     MR_offset_incr_hp_msg(new_data, MR_SIZE_SLOT_SIZE,
                         MR_SIZE_SLOT_SIZE + arity, MR_PROC_LABEL,
-                        ""<created by construct:construct/3>"");
+                        ""<created by construct.construct/3>"");
 
                     size = MR_cell_size(arity);
                     arg_list = ArgList;
@@ -586,25 +612,182 @@
                     MR_define_size_slot(MR_mktag(0), new_data, size);
                     if (! MR_list_is_empty(arg_list)) {
                         MR_fatal_error(
-                            ""excess arguments in construct:construct"");
+                            ""excess arguments in construct.construct"");
                     }
                 }
             }
             break;
 
         case MR_TYPECTOR_REP_DUMMY:
-            {
                 /*
                 ** The value of the dummy type will never be looked at,
-                ** so just set it to zero.
+            ** so it doesn't matter what new_data is set to.
                 */
                 new_data = (MR_Word) 0;
                 break;
-            }
+
+        case MR_TYPECTOR_REP_INT:
+            /* ints don't have functor ordinals. */
+            MR_fatal_error(
+                ""cannot construct int with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_FLOAT:
+            /* floats don't have functor ordinals. */
+            MR_fatal_error(
+                ""cannot construct floats with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_CHAR:
+            /* chars don't have functor ordinals. */
+            MR_fatal_error(
+                ""cannot construct chars with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_STRING:
+            /* strings don't have functor ordinals. */
+            MR_fatal_error(
+                ""cannot construct strings with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_EQUIV:
+        case MR_TYPECTOR_REP_EQUIV_GROUND:
+            /* These should be eliminated by MR_collapse_equivalences above. */
+            MR_fatal_error(""equiv type in in construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_VOID:
+            MR_fatal_error(
+                ""cannot construct void values with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_FUNC:
+            MR_fatal_error(
+                ""cannot construct functions with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_PRED:
+            MR_fatal_error(
+                ""cannot construct predicates with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_SUBGOAL:
+            MR_fatal_error(
+                ""cannot construct subgoals with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_TYPEDESC:
+            MR_fatal_error(
+                ""cannot construct type_descs with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_TYPECTORDESC:
+            MR_fatal_error(
+                ""cannot construct type_descs with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
+            MR_fatal_error(
+                ""cannot construct pseudotype_descs with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_TYPEINFO:
+            MR_fatal_error(
+                ""cannot construct type_infos with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_TYPECTORINFO:
+            MR_fatal_error(
+                ""cannot construct type_ctor_infos with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_TYPECLASSINFO:
+            MR_fatal_error(
+                ""cannot construct type_class_infos with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_BASETYPECLASSINFO:
+            MR_fatal_error(
+                ""cannot construct base_type_class_infos ""
+                ""with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_SUCCIP:
+            MR_fatal_error(
+                ""cannot construct succips with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_HP:
+            MR_fatal_error(
+                ""cannot construct hps with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_CURFR:
+            MR_fatal_error(
+                ""cannot construct curfrs with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_MAXFR:
+            MR_fatal_error(
+                ""cannot construct maxfrs with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_REDOFR:
+            MR_fatal_error(
+                ""cannot construct redofrs with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_REDOIP:
+            MR_fatal_error(
+                ""cannot construct redoips with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_TRAIL_PTR:
+            MR_fatal_error(
+                ""cannot construct trail_ptrs with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_TICKET:
+            MR_fatal_error(
+                ""cannot construct tickets with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_C_POINTER:
+        case MR_TYPECTOR_REP_STABLE_C_POINTER:
+            MR_fatal_error(
+                ""cannot construct c_pointers with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_ARRAY:
+            MR_fatal_error(
+                ""cannot construct arrays with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_REFERENCE:
+            MR_fatal_error(
+                ""cannot construct references with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_FOREIGN:
+        case MR_TYPECTOR_REP_STABLE_FOREIGN:
+            MR_fatal_error(
+                ""cannot construct values of foreign types ""
+                ""with construct.construct"");
+            break;
+
+        case MR_TYPECTOR_REP_UNKNOWN:
+            MR_fatal_error(
+                ""cannot construct values of unknown types ""
+                ""with construct.construct"");
+            break;
+
+#ifdef MR_INCLUDE_SWITCH_DEFAULTS
 
         default:
             new_data = (MR_Word) 0;     /* avoid a warning */
-            MR_fatal_error(""bad type_ctor_rep in construct:construct"");
+            MR_fatal_error(""bad type_ctor_rep in construct.construct"");
+
+#endif
         }
 
     end_of_main_switch:
@@ -651,7 +834,7 @@
     } else {
         MR_offset_incr_hp_msg(new_data, MR_SIZE_SLOT_SIZE,
             MR_SIZE_SLOT_SIZE + Arity, MR_PROC_LABEL,
-            ""<created by construct:construct_tuple/1>"");
+            ""<created by construct.construct_tuple/1>"");
 
         size = MR_cell_size(Arity);
         for (i = 0; i < Arity; i++) {
Index: library/deconstruct.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/deconstruct.m,v
retrieving revision 1.31
diff -u -b -r1.31 deconstruct.m
--- library/deconstruct.m	19 Sep 2005 04:29:00 -0000	1.31
+++ library/deconstruct.m	19 Nov 2005 00:48:38 -0000
@@ -216,36 +216,6 @@
 :- pred limited_deconstruct_cc(T::in, int::in,
     maybe({string, int, list(univ)})::out) is cc_multi.
 
-%----------------------------------------------------------------------------%
-%----------------------------------------------------------------------------%
-
-:- implementation.
-:- interface.
-
-% The rest of the interface is for use by implementors only.
-
-:- type functor_tag_info
-    --->    functor_integer(int)
-    ;       functor_float(float)
-    ;       functor_string(string)
-    ;       functor_enum(int)
-    ;       functor_local(int, int)
-    ;       functor_remote(int, int, list(univ))
-    ;       functor_unshared(int, list(univ))
-    ;       functor_notag(univ)
-    ;       functor_equiv(univ).
-
-    % get_functor_info is a variant of deconstruct for use by the compiler,
-    % specifically prog_rep.m and static_term.m. It differs from
-    % deconstruct in two main ways. First, instead of returning the
-    % function symbol, it returns implementation information about
-    % its tag. Second, it succeeds for just the kinds of terms needed
-    % to represent procedure bodies for ordinary procedures. For the time
-    % being, these are procedures that do not involve higher order code
-    % or tabling.
-    %
-:- pred get_functor_info(univ::in, functor_tag_info::out) is semidet.
-
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
@@ -260,19 +230,6 @@
 
 %-----------------------------------------------------------------------------%
 
-:- pragma foreign_decl("C", "
-
-#include ""mercury_deconstruct.h""
-#include ""mercury_deconstruct_macros.h""
-
-extern  MR_Word MR_make_arg_list(MR_TypeInfo type_info,
-                    const MR_DuFunctorDesc *functor_desc,
-                    MR_Word *arg_vector);
-
-").
-
-%-----------------------------------------------------------------------------%
-
 % XXX The no-inline pragmas are necessary because when it inlines a predicate
 % defined by foreign_procs, the compiler does not preserve the names of the
 % typeinfo variables. Thus these foreign_proc's references to TypeInfo_for_T
@@ -905,273 +862,3 @@
         Functor, Arity, Arguments).
 
 %-----------------------------------------------------------------------------%
-
-get_functor_info(Univ, FunctorInfo) :-
-    ( univ_to_type(Univ, Int) ->
-        FunctorInfo = functor_integer(Int)
-    ; univ_to_type(Univ, Float) ->
-        FunctorInfo = functor_float(Float)
-    ; univ_to_type(Univ, String) ->
-        FunctorInfo = functor_string(String)
-    ; get_enum_functor_info(Univ, Enum) ->
-        FunctorInfo = functor_enum(Enum)
-    %
-    % XXX We should handle reserved_addr types here.
-    %
-    ; get_du_functor_info(Univ, Where, Ptag, Sectag, Args) ->
-        ( Where = 0 ->
-            FunctorInfo = functor_unshared(Ptag, Args)
-        ; Where > 0 ->
-            FunctorInfo = functor_remote(Ptag, Sectag, Args)
-        ;
-            FunctorInfo = functor_local(Ptag, Sectag)
-        )
-    ; get_notag_functor_info(Univ, ExpUniv) ->
-        FunctorInfo = functor_notag(ExpUniv)
-    ; get_equiv_functor_info(Univ, ExpUniv) ->
-        FunctorInfo = functor_equiv(ExpUniv)
-    ;
-        fail
-    ).
-
-    % Given a value of an arbitrary type, succeed if its type is defined
-    % as a notag type, and return a univ which bundles up the value
-    % with the type of the single function symbol of the notag type.
-    %
-:- pred get_notag_functor_info(univ::in, univ::out) is semidet.
-
-:- pragma foreign_proc("C",
-    get_notag_functor_info(Univ::in, ExpUniv::out),
-    [will_not_call_mercury, thread_safe, promise_pure],
-"{
-    MR_TypeInfo                 type_info;
-    MR_TypeInfo                 exp_type_info;
-    MR_TypeCtorInfo             type_ctor_info;
-    const MR_NotagFunctorDesc   *functor_desc;
-    MR_Word                     value;
-
-    MR_unravel_univ(Univ, type_info, value);
-    type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-    switch (MR_type_ctor_rep(type_ctor_info)) {
-
-    case MR_TYPECTOR_REP_NOTAG:
-    case MR_TYPECTOR_REP_NOTAG_USEREQ:
-        functor_desc = MR_type_ctor_functors(type_ctor_info).MR_functors_notag;
-        exp_type_info = MR_pseudo_type_info_is_ground(
-            functor_desc->MR_notag_functor_arg_type);
-        MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
-        SUCCESS_INDICATOR = MR_TRUE;
-        break;
-
-    case MR_TYPECTOR_REP_NOTAG_GROUND:
-    case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
-        functor_desc = MR_type_ctor_functors(type_ctor_info).MR_functors_notag;
-        exp_type_info = MR_create_type_info(
-            MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
-            functor_desc->MR_notag_functor_arg_type);
-        MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
-        SUCCESS_INDICATOR = MR_TRUE;
-        break;
-
-    default:
-        SUCCESS_INDICATOR = MR_FALSE;
-        break;
-
-    }
-}").
-
-    % Given a value of an arbitrary type, succeed if its type is defined
-    % as an equivalence type, and return a univ which bundles up the value
-    % with the equivalent type. (I.e. this removes one layer of equivalence
-    % from the type stored in the univ.)
-    %
-:- pred get_equiv_functor_info(univ::in, univ::out) is semidet.
-
-:- pragma foreign_proc("C",
-    get_equiv_functor_info(Univ::in, ExpUniv::out),
-    [will_not_call_mercury, thread_safe, promise_pure],
-"{
-    MR_TypeInfo     type_info;
-    MR_TypeInfo     exp_type_info;
-    MR_TypeCtorInfo type_ctor_info;
-    MR_Word         value;
-
-    MR_unravel_univ(Univ, type_info, value);
-    type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-    switch (MR_type_ctor_rep(type_ctor_info)) {
-
-    case MR_TYPECTOR_REP_EQUIV:
-        exp_type_info = MR_pseudo_type_info_is_ground(
-            MR_type_ctor_layout(type_ctor_info).MR_layout_equiv);
-        MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
-        SUCCESS_INDICATOR = MR_TRUE;
-        break;
-
-    case MR_TYPECTOR_REP_EQUIV_GROUND:
-        exp_type_info = MR_create_type_info(
-            MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
-            MR_type_ctor_layout(type_ctor_info).MR_layout_equiv);
-        MR_new_univ_on_hp(ExpUniv, exp_type_info, value);
-        SUCCESS_INDICATOR = MR_TRUE;
-        break;
-
-    default:
-        SUCCESS_INDICATOR = MR_FALSE;
-        break;
-
-    }
-}").
-
-    % Given a value of an arbitrary type, succeed if it is an enum type,
-    % and return the integer value corresponding to the value.
-    %
-:- pred get_enum_functor_info(univ::in, int::out) is semidet.
-
-:- pragma foreign_proc("C",
-    get_enum_functor_info(Univ::in, Enum::out),
-    [will_not_call_mercury, thread_safe, promise_pure],
-"{
-    MR_TypeInfo     type_info;
-    MR_TypeCtorInfo type_ctor_info;
-    MR_Word         value;
-
-    MR_unravel_univ(Univ, type_info, value);
-    type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-    switch (MR_type_ctor_rep(type_ctor_info)) {
-
-    case MR_TYPECTOR_REP_ENUM:
-    case MR_TYPECTOR_REP_ENUM_USEREQ:
-        Enum = (MR_Integer) value;
-        SUCCESS_INDICATOR = MR_TRUE;
-        break;
-
-    default:
-        SUCCESS_INDICATOR = MR_FALSE;
-        break;
-
-    }
-}").
-
-    % Given a value of an arbitrary type, succeed if it is a general du type
-    % (i.e. non-enum, non-notag du type), and return the top function symbol's
-    % arguments as well as its tag information: an indication of where the
-    % secondary tag is (-1 for local secondary tag, 0 for nonexistent secondary
-    % tag, and 1 for remote secondary tag), as well as the primary and
-    % secondary tags themselves (the secondary tag argument will be meaningful
-    % only if the secondary tag exists, of course).
-    %
-:- pred get_du_functor_info(univ::in, int::out, int::out, int::out,
-    list(univ)::out) is semidet.
-
-:- pragma foreign_proc("C",
-    get_du_functor_info(Univ::in, Where::out, Ptag::out, Sectag::out,
-        Args::out),
-    [will_not_call_mercury, thread_safe, promise_pure],
-"{
-    MR_TypeInfo             type_info;
-    MR_TypeCtorInfo         type_ctor_info;
-    const MR_DuPtagLayout   *ptag_layout;
-    const MR_DuFunctorDesc  *functor_desc;
-    MR_Word                 value;
-    MR_Word                 *arg_vector;
-    int                     i;
-
-    MR_unravel_univ(Univ, type_info, value);
-    type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
-
-    switch (MR_type_ctor_rep(type_ctor_info)) {
-
-    case MR_TYPECTOR_REP_DU:
-    case MR_TYPECTOR_REP_DU_USEREQ:
-
-        SUCCESS_INDICATOR = MR_TRUE;
-        Ptag = MR_tag(value);
-        ptag_layout = &MR_type_ctor_layout(type_ctor_info).MR_layout_du[Ptag];
-
-        switch(ptag_layout->MR_sectag_locn) {
-
-            case MR_SECTAG_LOCAL:
-                Where = -1;
-                Sectag = MR_unmkbody(value);
-                Args = MR_list_empty();
-                break;
-
-            case MR_SECTAG_REMOTE:
-            case MR_SECTAG_NONE:
-                if (ptag_layout->MR_sectag_locn == MR_SECTAG_NONE) {
-                    Where = 0;
-                    arg_vector = (MR_Word *) MR_body(value, Ptag);
-                    Sectag = 0;
-                } else {
-                    Where = 1;
-                    arg_vector = (MR_Word *) MR_body(value, Ptag);
-                    Sectag = arg_vector[0];
-                    arg_vector++;
-                }
-
-                functor_desc =
-                    ptag_layout->MR_sectag_alternatives[Sectag];
-                if (functor_desc->MR_du_functor_exist_info != NULL) {
-                    SUCCESS_INDICATOR = MR_FALSE;
-                    break;
-                }
-
-                Args = MR_make_arg_list(type_info, functor_desc,
-                    arg_vector);
-                break;
-
-            case MR_SECTAG_VARIABLE:
-                MR_fatal_error(""get_du_functor_info: unexpected variable"");
-
-            default:
-                MR_fatal_error(""get_du_functor_info: unknown sectag locn"");
-        }
-
-        break;
-
-    default:
-        SUCCESS_INDICATOR = MR_FALSE;
-        break;
-
-    }
-}").
-
-:- pragma foreign_code("C", "
-
-/*
-** MR_make_arg_list is called from only one place above. If this changes,
-** we will need a mechanism to charge the memory we allocate here to the
-** right caller.
-*/
-
-MR_Word
-MR_make_arg_list(MR_TypeInfo type_info, const MR_DuFunctorDesc *functor_desc,
-    MR_Word *arg_vector)
-{
-    int         i;
-    MR_Word     args;
-
-    args = MR_list_empty_msg(mercury__deconstruct__get_du_functor_info_5_0);
-    for (i = functor_desc->MR_du_functor_orig_arity - 1; i >= 0; i--) {
-        MR_Word     arg;
-        MR_TypeInfo arg_type_info;
-
-        if (MR_arg_type_may_contain_var(functor_desc, i)) {
-            arg_type_info = MR_create_type_info_maybe_existq(
-                MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
-                functor_desc->MR_du_functor_arg_types[i],
-                arg_vector, functor_desc);
-        } else {
-            arg_type_info = MR_pseudo_type_info_is_ground(
-                functor_desc->MR_du_functor_arg_types[i]);
-        }
-
-        MR_new_univ_on_hp(arg, arg_type_info, arg_vector[i]);
-        args = MR_univ_list_cons_msg(arg, args,
-            mercury__deconstruct__get_du_functor_info_5_0);
-    }
-
-    return args;
-}
-
-").
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/mercury_conf_param.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_conf_param.h,v
retrieving revision 1.85
diff -u -b -r1.85 mercury_conf_param.h
--- runtime/mercury_conf_param.h	13 Sep 2005 08:25:37 -0000	1.85
+++ runtime/mercury_conf_param.h	19 Nov 2005 00:41:55 -0000
@@ -144,6 +144,12 @@
 **
 ** MR_CHECK_TYPECLASS_REFS
 ** 	Check for improper use of typeclass_infos and base_typeclass_infos.
+**
+** MR_INCLUDE_SWITCH_DEFAULTS
+** 	When performing switches over enum types defined in the runtime,
+**	include a default case even if the switch is complete, to guard against
+**	e.g. memory corruption of the switched-ondata item taking it outside
+**	the legal range of that enum.
 */
 
 /*
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 slice
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
--------------------------------------------------------------------------



More information about the reviews mailing list