[MLton-commit] r4086

[Stephen Weeks]

Fixed Subscript bug in signature matching.

The bug was tickled by the following program, which caused an
unhandled exception to be raised.

  signature X =
     sig
        type x = unit
     end
  
  structure X :> X =
     struct
        type 'a x = unit
     end

The problem was in the isPlausible function, introduced back in
revision 3744.  It was checking schemes too early, under the
assumption that the type arities were equal, rather than waiting until
after the check that verified that they were (which in the above case
would fail).  The fix was to delay the checkSchemes call until after
isPlausible succeeds.


----------------------------------------------------------------------

U   mlton/trunk/mlton/elaborate/elaborate-env.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2005-09-09 23:29:50 UTC (rev 4085)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2005-09-11 16:18:55 UTC (rev 4086)
@@ -2673,18 +2673,26 @@
                         Datatype {cons = sigCons, ...} =>
                            (case TypeStr.node structStr of
                                Datatype {cons = structCons, ...} =>
-                                  (checkCons (structCons, sigCons, strids, name)
-                                   ; (structStr, false))
-                             | _ => (sigStr, true))
-                      | Scheme s => (checkScheme s; (sigStr, false))
-                      | Tycon c => (checkScheme (tyconScheme c); (sigStr, false))
+                                  (fn () =>
+                                   (checkCons (structCons, sigCons, strids,
+                                               name)
+                                    ; structStr),
+                                   false)
+                             | _ => (fn () => sigStr, true))
+                      | Scheme s =>
+                           (fn () => (checkScheme s; sigStr),
+                            false)
+                      | Tycon c =>
+                           (fn () => (checkScheme (tyconScheme c); sigStr),
+                            false)
                in
-                  if not (isPlausible (structStr, strids, name,
-                                       TypeStr.admitsEquality sigStr,
-                                       TypeStr.kind sigStr,
-                                       consMismatch))
-                     then sigStr
-                  else return
+                  if isPlausible (structStr, strids, name,
+                                  TypeStr.admitsEquality sigStr,
+                                  TypeStr.kind sigStr,
+                                  consMismatch) then
+                     return ()
+                  else
+                     sigStr
                end
       fun map (structInfo: ('a, 'b) Info.t,
                sigArray: ('a * 'c) array,