summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2012-03-29 09:55:04 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2012-03-29 09:55:04 -0400
commitc0e9784e1cfc3f377e1144833597e4dcd5472e84 (patch)
treec681bccc3c5734fd488af8fc816900fe39ff91fd
parenta613f7d9361f504290757c686d87f56dc1e7b088 (diff)
Fix defunctorization of modules containing datatype definitions
-rw-r--r--src/corify.sml37
-rw-r--r--tests/dtfunctor.ur9
2 files changed, 32 insertions, 14 deletions
diff --git a/src/corify.sml b/src/corify.sml
index fe73072b..5cfd87b3 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2010, Adam Chlipala
+(* Copyright (c) 2008-2012, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -91,7 +91,8 @@ structure St : sig
val lookupConById : t -> int -> int option
val lookupConByName : t -> string -> core_con
- val bindConstructor : t -> string -> int -> L'.patCon -> t
+ val bindConstructor : t -> string -> int -> t * int
+ val bindConstructorAs : t -> string -> int -> L'.patCon -> t
val lookupConstructorByNameOpt : t -> string -> L'.patCon option
val lookupConstructorByName : t -> string -> L'.patCon
val lookupConstructorById : t -> int -> L'.patCon
@@ -100,7 +101,7 @@ structure St : sig
ENormal of int
| EFfi of string * L'.con
val bindVal : t -> string -> int -> t * int
- val bindConstructorVal : t -> string -> int -> t
+ val bindConstructorVal : t -> string -> int -> int -> t
val lookupValById : t -> int -> int option
val lookupValByName : t -> string -> core_val
@@ -241,7 +242,7 @@ fun bindVal {basis, cons, constructors, vals, strs, funs, current, nested} s n =
n')
end
-fun bindConstructorVal {basis, cons, constructors, vals, strs, funs, current, nested} s n =
+fun bindConstructorVal {basis, cons, constructors, vals, strs, funs, current, nested} s n n' =
let
val current =
case current of
@@ -250,14 +251,14 @@ fun bindConstructorVal {basis, cons, constructors, vals, strs, funs, current, ne
FNormal {name = name,
cons = cons,
constructors = constructors,
- vals = SM.insert (vals, s, n),
+ vals = SM.insert (vals, s, n'),
strs = strs,
funs = funs}
in
{basis = basis,
cons = cons,
constructors = constructors,
- vals = IM.insert (vals, n, n),
+ vals = IM.insert (vals, n, n'),
strs = strs,
funs = funs,
current = current,
@@ -278,7 +279,7 @@ fun lookupValByName ({current, ...} : t) x =
NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." (rev name) ^ "." ^ x)
| SOME n => ENormal n
-fun bindConstructor {basis, cons, constructors, vals, strs, funs, current, nested} s n n' =
+fun bindConstructorAs {basis, cons, constructors, vals, strs, funs, current, nested} s n c' =
let
val current =
case current of
@@ -286,14 +287,14 @@ fun bindConstructor {basis, cons, constructors, vals, strs, funs, current, neste
| FNormal {name, cons, constructors, vals, strs, funs} =>
FNormal {name = name,
cons = cons,
- constructors = SM.insert (constructors, s, n'),
+ constructors = SM.insert (constructors, s, c'),
vals = vals,
strs = strs,
funs = funs}
in
{basis = basis,
cons = cons,
- constructors = IM.insert (constructors, n, n'),
+ constructors = IM.insert (constructors, n, c'),
vals = vals,
strs = strs,
funs = funs,
@@ -301,6 +302,14 @@ fun bindConstructor {basis, cons, constructors, vals, strs, funs, current, neste
nested = nested}
end
+fun bindConstructor st s n =
+ let
+ val n' = alloc ()
+ val c' = L'.PConVar n'
+ in
+ (bindConstructorAs st s n c', n')
+ end
+
fun lookupConstructorById ({constructors, ...} : t) n =
case IM.find (constructors, n) of
NONE => raise Fail "Corify.St.lookupConstructorById"
@@ -642,11 +651,11 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
val (xncs, st) = ListUtil.foldlMap
(fn ((x, n, co), st) =>
let
- val st = St.bindConstructor st x n (L'.PConVar n)
- val st = St.bindConstructorVal st x n
+ val (st, n') = St.bindConstructor st x n
+ val st = St.bindConstructorVal st x n n'
val co = Option.map (corifyCon st) co
in
- ((x, n, co), st)
+ ((x, n', co), st)
end) st xncs
val dk = ElabUtil.classifyDatatype xncs
@@ -695,7 +704,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
val (xncs, st) = ListUtil.foldlMap (fn ((x, n, co), st) =>
let
val n' = St.lookupConstructorByName inner x
- val st = St.bindConstructor st x n n'
+ val st = St.bindConstructorAs st x n n'
val (st, n) = St.bindVal st x n
val co = Option.map (corifyCon st) co
in
@@ -884,7 +893,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
(SM.insert (cmap, x', wrapT tf), d)
end
- val st = St.bindConstructor st x' n pc
+ val st = St.bindConstructorAs st x' n pc
val conmap = SM.insert (conmap, x',
(x, xs, to, dk))
diff --git a/tests/dtfunctor.ur b/tests/dtfunctor.ur
new file mode 100644
index 00000000..84257479
--- /dev/null
+++ b/tests/dtfunctor.ur
@@ -0,0 +1,9 @@
+functor Make(M : sig end) = struct
+ datatype t = A | B
+end
+
+structure A = Make(struct end)
+structure B = Make(struct end)
+
+fun main (x : A.t) (y : B.t) : transaction page =
+ return <xml/>