[MLton-devel] cvs commit: type variable scope inference
Stephen Weeks
sweeks@users.sourceforge.net
Mon, 21 Jul 2003 14:53:51 -0700
sweeks 03/07/21 14:53:51
Modified: mlton mlton-stubs-1997.cm mlton-stubs.cm mlton.cm
mlton/ast ast-atoms.sig ast-core.fun ast-core.sig
mlton/atoms atoms.fun atoms.sig
mlton/elaborate elaborate-core.fun sources.cm
mlton/type-inference infer.fun sources.cm
Added: mlton/elaborate scope.fun scope.sig
Removed: mlton/type-inference scope.fun scope.sig
Log:
Moved type variable scope inference from CoreML to Ast. This is the
first step in making a proper front end.
Revision Changes Path
1.24 +7 -7 mlton/mlton/mlton-stubs-1997.cm
Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- mlton-stubs-1997.cm 19 Jul 2003 01:23:25 -0000 1.23
+++ mlton-stubs-1997.cm 21 Jul 2003 21:53:50 -0000 1.24
@@ -146,7 +146,6 @@
control/region.sig
control/region.sml
../lib/mlton/set/set.sig
-../lib/mlton/env/mono-env.sig
ast/word-size.sig
ast/wrapped.sig
ast/tyvar.sig
@@ -250,12 +249,9 @@
ast/ast-core.fun
ast/ast.fun
../lib/mlton/set/unordered.fun
-../lib/mlton/env/basic-env-to-env.fun
-../lib/mlton/env/mono-env.fun
atoms/word-x.fun
atoms/id.fun
atoms/var.fun
-atoms/use-name.fun
atoms/type-ops.fun
atoms/type.fun
atoms/tycon.fun
@@ -478,9 +474,15 @@
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
elaborate/elaborate-sigexp.fun
-elaborate/elaborate-core.sig
+../lib/mlton/env/mono-env.sig
+../lib/mlton/env/basic-env-to-env.fun
+../lib/mlton/env/mono-env.fun
+atoms/use-name.fun
+elaborate/scope.sig
+elaborate/scope.fun
elaborate/precedence-parse.sig
elaborate/precedence-parse.fun
+elaborate/elaborate-core.sig
elaborate/elaborate-core.fun
elaborate/elaborate.fun
control/source.sig
@@ -492,8 +494,6 @@
front-end/front-end.fun
type-inference/type-env.sig
type-inference/type-env.fun
-type-inference/scope.sig
-type-inference/scope.fun
type-inference/nested-pat.sig
type-inference/nested-pat.fun
type-inference/match-compile.sig
1.29 +7 -7 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- mlton-stubs.cm 19 Jul 2003 01:23:25 -0000 1.28
+++ mlton-stubs.cm 21 Jul 2003 21:53:50 -0000 1.29
@@ -145,7 +145,6 @@
control/region.sig
control/region.sml
../lib/mlton/set/set.sig
-../lib/mlton/env/mono-env.sig
ast/word-size.sig
ast/wrapped.sig
ast/tyvar.sig
@@ -249,12 +248,9 @@
ast/ast-core.fun
ast/ast.fun
../lib/mlton/set/unordered.fun
-../lib/mlton/env/basic-env-to-env.fun
-../lib/mlton/env/mono-env.fun
atoms/word-x.fun
atoms/id.fun
atoms/var.fun
-atoms/use-name.fun
atoms/type-ops.fun
atoms/type.fun
atoms/tycon.fun
@@ -477,9 +473,15 @@
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
elaborate/elaborate-sigexp.fun
-elaborate/elaborate-core.sig
+../lib/mlton/env/mono-env.sig
+../lib/mlton/env/basic-env-to-env.fun
+../lib/mlton/env/mono-env.fun
+atoms/use-name.fun
+elaborate/scope.sig
+elaborate/scope.fun
elaborate/precedence-parse.sig
elaborate/precedence-parse.fun
+elaborate/elaborate-core.sig
elaborate/elaborate-core.fun
elaborate/elaborate.fun
control/source.sig
@@ -491,8 +493,6 @@
front-end/front-end.fun
type-inference/type-env.sig
type-inference/type-env.fun
-type-inference/scope.sig
-type-inference/scope.fun
type-inference/nested-pat.sig
type-inference/nested-pat.fun
type-inference/match-compile.sig
1.71 +7 -7 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -r1.70 -r1.71
--- mlton.cm 19 Jul 2003 01:23:25 -0000 1.70
+++ mlton.cm 21 Jul 2003 21:53:50 -0000 1.71
@@ -112,7 +112,6 @@
control/region.sig
control/region.sml
../lib/mlton/set/set.sig
-../lib/mlton/env/mono-env.sig
ast/word-size.sig
ast/wrapped.sig
ast/tyvar.sig
@@ -216,12 +215,9 @@
ast/ast-core.fun
ast/ast.fun
../lib/mlton/set/unordered.fun
-../lib/mlton/env/basic-env-to-env.fun
-../lib/mlton/env/mono-env.fun
atoms/word-x.fun
atoms/id.fun
atoms/var.fun
-atoms/use-name.fun
atoms/type-ops.fun
atoms/type.fun
atoms/tycon.fun
@@ -444,9 +440,15 @@
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
elaborate/elaborate-sigexp.fun
-elaborate/elaborate-core.sig
+../lib/mlton/env/mono-env.sig
+../lib/mlton/env/basic-env-to-env.fun
+../lib/mlton/env/mono-env.fun
+atoms/use-name.fun
+elaborate/scope.sig
+elaborate/scope.fun
elaborate/precedence-parse.sig
elaborate/precedence-parse.fun
+elaborate/elaborate-core.sig
elaborate/elaborate-core.fun
elaborate/elaborate.fun
control/source.sig
@@ -458,8 +460,6 @@
front-end/front-end.fun
type-inference/type-env.sig
type-inference/type-env.fun
-type-inference/scope.sig
-type-inference/scope.fun
type-inference/nested-pat.sig
type-inference/nested-pat.fun
type-inference/match-compile.sig
1.3 +4 -4 mlton/mlton/ast/ast-atoms.sig
Index: ast-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ast-atoms.sig 10 Apr 2002 07:02:18 -0000 1.2
+++ ast-atoms.sig 21 Jul 2003 21:53:50 -0000 1.3
@@ -104,9 +104,9 @@
structure TypBind:
sig
type t
- datatype node = T of {tyvars: Tyvar.t vector,
+ datatype node = T of {def: Type.t,
tycon: Tycon.t,
- def: Type.t} list
+ tyvars: Tyvar.t vector} list
include WRAPPED sharing type node' = node
sharing type obj = t
@@ -117,9 +117,9 @@
sig
type t
datatype node =
- T of {datatypes: {tyvars: Tyvar.t vector,
+ T of {datatypes: {cons: (Con.t * Type.t option) vector,
tycon: Tycon.t,
- cons: (Con.t * Type.t option) vector} vector,
+ tyvars: Tyvar.t vector} vector,
withtypes: TypBind.t}
include WRAPPED sharing type node' = node
sharing type obj = t
1.13 +24 -24 mlton/mlton/ast/ast-core.fun
Index: ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- ast-core.fun 19 Jul 2003 01:23:26 -0000 1.12
+++ ast-core.fun 21 Jul 2003 21:53:50 -0000 1.13
@@ -84,20 +84,20 @@
struct
open Wrap
datatype node =
- Wild
- | Var of {fixop: Fixop.t, name: Longvid.t}
+ App of Longcon.t * t
| Const of Const.t
- | Tuple of t vector
- | Record of {items: item vector,
- flexible: bool}
- | List of t list
- | FlatApp of t vector
- | App of Longcon.t * t
| Constraint of t * Type.t
+ | FlatApp of t vector
| Layered of {fixop: Fixop.t,
var: Var.t,
constraint: Type.t option,
pat: t}
+ | List of t list
+ | Record of {flexible: bool,
+ items: item vector}
+ | Tuple of t vector
+ | Var of {fixop: Fixop.t, name: Longvid.t}
+ | Wild
and item =
Field of Record.Field.t * t
| Vid of Vid.t * Type.t option * t option
@@ -286,27 +286,27 @@
name: string,
ty: Type.t}
and decNode =
- Val of {tyvars: Tyvar.t vector,
- vbs: {pat: Pat.t,
- exp: exp,
- filePos: string} vector,
- rvbs: {pat: Pat.t,
- match: match} vector}
- | Fun of Tyvar.t vector * {clauses: {pats: Pat.t vector,
- resultType: Type.t option,
- body: exp} vector,
- filePos: string} vector
- | Type of TypBind.t
+ Abstype of {body: dec,
+ datBind: DatBind.t}
| Datatype of DatatypeRhs.t
- | Abstype of {datBind: DatBind.t,
- body: dec}
| Exception of Eb.t vector
+ | Fix of {fixity: Fixity.t,
+ ops: Vid.t vector}
+ | Fun of Tyvar.t vector * {clauses: {body: exp,
+ pats: Pat.t vector,
+ resultType: Type.t option} vector,
+ filePos: string} vector
| Local of dec * dec
- | SeqDec of dec vector
| Open of Longstrid.t vector
| Overload of Var.t * Type.t * Longvar.t vector
- | Fix of {fixity: Fixity.t,
- ops: Vid.t vector}
+ | SeqDec of dec vector
+ | Type of TypBind.t
+ | Val of {tyvars: Tyvar.t vector,
+ vbs: {exp: exp,
+ filePos: string,
+ pat: Pat.t} vector,
+ rvbs: {match: match,
+ pat: Pat.t} vector}
and match = T of {filePos: string,
rules: (Pat.t * exp) vector}
withtype
1.9 +24 -23 mlton/mlton/ast/ast-core.sig
Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- ast-core.sig 19 Jul 2003 01:23:26 -0000 1.8
+++ ast-core.sig 21 Jul 2003 21:53:50 -0000 1.9
@@ -50,15 +50,16 @@
| Const of Const.t
| Constraint of t * Type.t
| FlatApp of t vector
- | Layered of {fixop: Fixop.t,
- var: Var.t,
- constraint: Type.t option,
- pat: t}
+ | Layered of {constraint: Type.t option,
+ fixop: Fixop.t,
+ pat: t,
+ var: Var.t}
| List of t list
- | Record of {items: Item.t vector,
- flexible: bool}
+ | Record of {flexible: bool,
+ items: Item.t vector}
| Tuple of t vector
- | Var of {fixop: Fixop.t, name: Longvid.t}
+ | Var of {fixop: Fixop.t,
+ name: Longvid.t}
| Wild
include WRAPPED sharing type node' = node
@@ -160,8 +161,8 @@
sig
type t
datatype node =
- Gen of Type.t option
- | Def of Longcon.t
+ Def of Longcon.t
+ | Gen of Type.t option
include WRAPPED sharing type node' = node
sharing type obj = t
end
@@ -170,27 +171,27 @@
sig
type t
datatype node =
- Val of {tyvars: Tyvar.t vector,
- vbs: {pat: Pat.t,
- exp: Exp.t,
- filePos: string} vector,
- rvbs: {pat: Pat.t,
- match: Match.t} vector}
+ Abstype of {datBind: DatBind.t,
+ body: t}
+ | Datatype of DatatypeRhs.t
+ | Exception of (Con.t * EbRhs.t) vector
+ | Fix of {fixity: Fixity.t,
+ ops: Vid.t vector}
| Fun of Tyvar.t vector * {clauses: {pats: Pat.t vector,
resultType: Type.t option,
body: Exp.t} vector,
filePos: string} vector
- | Type of TypBind.t
- | Datatype of DatatypeRhs.t
- | Abstype of {datBind: DatBind.t,
- body: t}
- | Exception of (Con.t * EbRhs.t) vector
- | SeqDec of t vector
| Local of t * t
| Open of Longstrid.t vector
| Overload of Var.t * Type.t * Longvar.t vector
- | Fix of {fixity: Fixity.t,
- ops: Vid.t vector}
+ | SeqDec of t vector
+ | Type of TypBind.t
+ | Val of {rvbs: {match: Match.t,
+ pat: Pat.t} vector,
+ tyvars: Tyvar.t vector,
+ vbs: {exp: Exp.t,
+ filePos: string,
+ pat: Pat.t} vector}
include WRAPPED sharing type node' = node
sharing type obj = t
1.10 +0 -19 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- atoms.fun 19 Jul 2003 01:23:26 -0000 1.9
+++ atoms.fun 21 Jul 2003 21:53:50 -0000 1.10
@@ -70,25 +70,6 @@
structure Vars = UnorderedSet (Var)
structure Cons = UnorderedSet (Con)
structure Tycons = UnorderedSet (Tycon)
- structure TyvarEnv =
- struct
- structure Env = MonoEnv (structure Domain = UseName (Tyvar)
- structure Range = Tyvar)
- open Env
-
- fun rename (env: t, tyvars: Tyvar.t vector): t * Tyvar.t vector =
- let
- val (tyvars, env) =
- Vector.mapAndFold
- (tyvars, env, fn (tyv, env) =>
- let
- val tyv' =
- Tyvar.newNoname {equality = Tyvar.isEquality tyv}
- in (tyv', extend (env, tyv, tyv'))
- end)
- in (env, tyvars)
- end
- end
end
open Atoms
1.10 +0 -12 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- atoms.sig 19 Jul 2003 01:23:26 -0000 1.9
+++ atoms.sig 21 Jul 2003 21:53:50 -0000 1.10
@@ -36,16 +36,6 @@
structure Tyvar: TYVAR
structure Var: VAR
structure Vars: SET
- structure TyvarEnv:
- sig
- include MONO_ENV
-
- (* rename (env, tyvars) extends env by mapping each tyvar to
- * a new tyvar (with the same equality property). It returns
- * the extended environment and the list of new tyvars
- *)
- val rename: t * Tyvar.t vector -> t * Tyvar.t vector
- end
structure Tyvars: SET
structure WordX: WORD_X
@@ -75,8 +65,6 @@
sharing WordX = Const.WordX
sharing type Con.t = Cons.Element.t
sharing type Tycon.t = Tycons.Element.t
- sharing type Tyvar.t = TyvarEnv.Domain.t
- sharing type Tyvar.t = TyvarEnv.Range.t
sharing type Tyvar.t = Tyvars.Element.t
sharing type Var.t = Vars.Element.t
end
1.24 +3 -1 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- elaborate-core.fun 20 Jul 2003 18:07:58 -0000 1.23
+++ elaborate-core.fun 21 Jul 2003 21:53:50 -0000 1.24
@@ -68,6 +68,8 @@
structure Parse = PrecedenceParse (structure Ast = Ast
structure Env = Env)
+structure Scope = Scope (structure Ast = Ast)
+
structure Apat =
struct
open Apat
@@ -1082,7 +1084,7 @@
Env.scope (E, fn () => (elaboratePat (pat, E),
elabExp' (exp, nest))))}
in
- elabDec (d, nest)
+ elabDec (Scope.scope d, nest)
end
end
1.3 +11 -9 mlton/mlton/elaborate/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.2
+++ sources.cm 21 Jul 2003 21:53:50 -0000 1.3
@@ -18,16 +18,18 @@
../core-ml/sources.cm
../../lib/mlton/sources.cm
-decs.sig
+
decs.fun
-elaborate-env.sig
-elaborate-env.fun
-precedence-parse.sig
-precedence-parse.fun
-elaborate-core.sig
+decs.sig
elaborate-core.fun
-elaborate-sigexp.sig
+elaborate-core.sig
+elaborate-env.fun
+elaborate-env.sig
elaborate-sigexp.fun
-elaborate.sig
+elaborate-sigexp.sig
elaborate.fun
-
+elaborate.sig
+precedence-parse.fun
+precedence-parse.sig
+scope.fun
+scope.sig
1.1 mlton/mlton/elaborate/scope.fun
Index: scope.fun
===================================================================
(* Copyright (C) 1999-2003 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
(*
* renameDec walks down the tree renaming all explicitly bound tyvars, and on the
* way back up, tries to bind implicitly scoped tyvars at each possible point.
*
* removeDec walks down and binds a tyvar as soon as it sees it, removing all
* lower binding occurrences of the tyvar.
*
* removeDec also renames all lower free occurrences of the tyvar to be the
* "same" as the binding occurrence (so that they can share info).
*)
functor Scope (S: SCOPE_STRUCTS): SCOPE =
struct
open S
open Ast
structure Tyvars = UnorderedSet (UseName (Tyvar))
structure Env =
struct
structure Env = MonoEnv (structure Domain = UseName (Tyvar)
structure Range = Tyvar)
open Env
(* rename (env, tyvars) extends env by mapping each tyvar to
* a new tyvar (with the same equality property). It returns
* the extended environment and the list of new tyvars.
*)
fun rename (env: t, tyvars: Tyvar.t vector): t * Tyvar.t vector =
let
val (tyvars, env) =
Vector.mapAndFold
(tyvars, env, fn (tyv, env) =>
let
val tyv' =
Tyvar.newNoname {equality = Tyvar.isEquality tyv}
in (tyv', extend (env, tyv, tyv'))
end)
in (env, tyvars)
end
end
fun ('down, 'up)
processDec (d: Dec.t,
{
bind: 'down * Tyvar.t vector -> ('down
* Tyvar.t vector
* ('up -> 'up)),
bind': 'down * Tyvar.t vector -> ('down
* ('up -> (Tyvar.t vector
* 'up))),
combineUp: 'up * 'up -> 'up,
initDown: 'down,
initUp: 'up,
tyvar: Tyvar.t * 'down -> Tyvar.t * 'up
}): Dec.t * 'up =
let
fun loops (xs: 'a vector, loopX: 'a -> 'a * 'up): 'a vector * 'up =
Vector.mapAndFold (xs, initUp, fn (x, u) =>
let
val (x, u') = loopX x
in
(x, combineUp (u, u'))
end)
fun loopTy (t: Type.t, d: 'down): Type.t * 'up =
let
fun loop (t: Type.t): Type.t * 'up =
let
datatype z = datatype Type.node
val (n, u) =
case Type.node t of
Con (c, ts) =>
let
val (ts, u) = loops (ts, loop)
in
(Con (c, ts), u)
end
| Record r =>
let
val (r, u) = SortedRecord.change (r, fn ts =>
loops (ts, loop))
in
(Record r, u)
end
| Var a =>
let
val (a, u) = tyvar (a, d)
in
(Var a, u)
end
in
(Type.makeRegion (n, Type.region t), u)
end
in
loop t
end
fun loopTyOpt (to: Type.t option, d: 'down): Type.t option * 'up =
case to of
NONE => (NONE, initUp)
| SOME t =>
let
val (t, u) = loopTy (t, d)
in
(SOME t, u)
end
fun loopTypBind (tb: TypBind.t, d: 'down): TypBind.t * 'up =
let
val TypBind.T tbs = TypBind.node tb
val (tbs, u) =
loops (Vector.fromList tbs, fn {def, tycon, tyvars} =>
let
val (d, tyvars, finish) = bind (d, tyvars)
val (def, u) = loopTy (def, d)
in
({def = def,
tycon = tycon,
tyvars = tyvars},
finish u)
end)
in
(TypBind.makeRegion (TypBind.T (Vector.toList tbs),
TypBind.region tb),
u)
end
fun loopDatBind (db: DatBind.t, d: 'down): DatBind.t * 'up =
let
val DatBind.T {datatypes, withtypes} = DatBind.node db
val (datatypes, u) =
loops
(datatypes, fn {cons, tycon, tyvars} =>
let
val (d, tyvars, up) = bind (d, tyvars)
val (cons, u) =
loops (cons, fn (con, arg) =>
let
val (arg, u) = loopTyOpt (arg, d)
in
((con, arg), u)
end)
in
({cons = cons, tycon = tycon, tyvars = tyvars}, up u)
end)
val (withtypes, u') = loopTypBind (withtypes, d)
in
(DatBind.makeRegion (DatBind.T {datatypes = datatypes,
withtypes = withtypes},
DatBind.region db),
combineUp (u, u'))
end
fun loopPat (p: Pat.t, d: 'down): Pat.t * 'up =
let
fun loop (p: Pat.t): Pat.t * 'up =
let
fun doit n = Pat.makeRegion (n, Pat.region p)
fun do1 ((a, u), f) = (doit (f a), u)
fun do2 ((a1, u1), (a2, u2), f) =
(doit (f (a1, a2)), combineUp (u1, u2))
datatype z = datatype Pat.node
in
case Pat.node p of
App (c, p) => do1 (loop p, fn p => App (c, p))
| Const _ => (p, initUp)
| Constraint (p, t) =>
do2 (loop p, loopTy (t, d), Constraint)
| FlatApp ps => do1 (loops (ps, loop), FlatApp)
| Layered {constraint, fixop, pat, var} =>
do2 (loopTyOpt (constraint, d), loop pat,
fn (constraint, pat) =>
Layered {constraint = constraint,
fixop = fixop,
pat = pat,
var = var})
| List ps => do1 (loops (Vector.fromList ps, loop),
fn ps => List (Vector.toList ps))
| Record {flexible, items} =>
let
val (items, u) =
Vector.mapAndFold
(items, initUp, fn (i, u) =>
let
datatype z = datatype Pat.Item.t
val (i, u') =
case i of
Field (f, p) =>
let
val (p, u) = loop p
in
(Field (f, p), u)
end
| Vid (v, to, po) =>
let
val (to, u) = loopTyOpt (to, d)
val (po, u') = loopOpt po
in
(Vid (v, to, po),
combineUp (u, u'))
end
in
(i, combineUp (u, u'))
end)
in
(doit (Record {items = items,
flexible = flexible}),
u)
end
| Tuple ps => do1 (loops (ps, loop), Tuple)
| Var _ => (p, initUp)
| Wild => (p, initUp)
end
and loopOpt opt =
case opt of
NONE =>
(NONE, initUp)
| SOME p =>
let
val (p, u) = loop p
in
(SOME p, u)
end
in
loop p
end
fun loopDec (d: Dec.t, down: 'down): Dec.t * 'up =
let
fun doit n = Dec.makeRegion (n, Dec.region d)
fun do1 ((a, u), f) = (doit (f a), u)
fun do2 ((a1, u1), (a2, u2), f) =
(doit (f (a1, a2)), combineUp (u1, u2))
fun doVec (ds: Dec.t vector, f: Dec.t vector -> Dec.node)
: Dec.t * 'up =
let
val (ds, u) = loops (ds, fn d => loopDec (d, down))
in
(doit (f ds), u)
end
fun empty () = (d, initUp)
datatype z = datatype Dec.node
in
case Dec.node d of
Abstype {body, datBind} =>
let
val (body, u) = loopDec (body, down)
val (db, u') = loopDatBind (datBind, down)
in
(doit (Abstype {body = body, datBind = db}),
combineUp (u, u'))
end
| Datatype rhs =>
let
datatype z = datatype DatatypeRhs.node
val (rhs, u) =
case DatatypeRhs.node rhs of
DatBind db =>
let
val (db, u) = loopDatBind (db, down)
in
(DatatypeRhs.makeRegion
(DatBind db, DatatypeRhs.region rhs),
u)
end
| Repl _ => (rhs, initUp)
in
(doit (Datatype rhs), u)
end
| Exception ebs =>
let
val (ebs, u) =
loops (ebs, fn (c, rhs) =>
let
datatype z = datatype EbRhs.node
val (rhs, u) =
case EbRhs.node rhs of
Def _ => (rhs, initUp)
| Gen to =>
let
val (to, u) = loopTyOpt (to, down)
in
(EbRhs.makeRegion
(Gen to, EbRhs.region rhs),
u)
end
in
((c, rhs), u)
end)
in
(doit (Exception ebs), u)
end
| Fix _ => (d, initUp)
| Fun (tyvars, decs) =>
let
val (down, finish) = bind' (down, tyvars)
val (decs, u) =
loops (decs, fn {clauses, filePos} =>
let
val (clauses, u) =
loops
(clauses, fn {body, pats, resultType} =>
let
val (body, u) = loopExp (body, down)
val (pats, u') =
loops (pats, fn p =>
loopPat (p, down))
val (resultType, u'') =
loopTyOpt (resultType, down)
in
({body = body,
pats = pats,
resultType = resultType},
combineUp (u, combineUp (u', u'')))
end)
in
({clauses = clauses,
filePos = filePos},
u)
end)
val (tyvars, u) = finish u
in
(doit (Fun (tyvars, decs)), u)
end
| Local (d, d') =>
do2 (loopDec (d, down), loopDec (d', down), Local)
| Open _ => empty ()
| Overload _ => empty ()
| SeqDec ds => doVec (ds, SeqDec)
| Type tb => do1 (loopTypBind (tb, down), Type)
| Val {rvbs, tyvars, vbs} =>
let
val (down, finish) = bind' (down, tyvars)
val (rvbs, u) =
loops (rvbs, fn {match, pat} =>
let
val (match, u) = loopMatch (match, down)
val (pat, u') = loopPat (pat, down)
in
({match = match,
pat = pat},
combineUp (u, u'))
end)
val (vbs, u') =
loops (vbs, fn {exp, filePos, pat} =>
let
val (exp, u) = loopExp (exp, down)
val (pat, u') = loopPat (pat, down)
in
({exp = exp,
filePos = filePos,
pat = pat},
combineUp (u, u'))
end)
val (tyvars, u) = finish (combineUp (u, u'))
in
(doit (Val {rvbs = rvbs,
tyvars = tyvars,
vbs = vbs}),
u)
end
end
and loopDecs (ds, down) = loops (ds, fn d => loopDec (d, down))
and loopExp (e: Exp.t, d: 'down): Exp.t * 'up =
let
val loopMatch = fn m => loopMatch (m, d)
fun loop (e: Exp.t): Exp.t * 'up =
let
fun empty () = (e, initUp)
val region = Exp.region e
fun doit n = Exp.makeRegion (n, region)
datatype z = datatype Exp.node
fun do1 ((a, u), f) = (doit (f a), u)
fun do2 ((a1, u1), (a2, u2), f) =
(doit (f (a1, a2)), combineUp (u1, u2))
fun do3 ((a1, u1), (a2, u2), (a3, u3), f) =
(doit (f (a1, a2, a3)), combineUp (u1, combineUp (u2, u3)))
fun doVec (es: Exp.t vector, f: Exp.t vector -> Exp.node)
: Exp.t * 'up =
let
val (es, u) = loops (es, loop)
in
(doit (f es), u)
end
fun doList (es: Exp.t list, f: Exp.t list -> Exp.node)
: Exp.t * 'up =
let
val (es, u) = loops (Vector.fromList es, loop)
in
(doit (f (Vector.toList es)), u)
end
in
case Exp.node e of
Andalso (e1, e2) => do2 (loop e1, loop e2, Andalso)
| App (e1, e2) => do2 (loop e1, loop e2, App)
| Case (e, m) => do2 (loop e, loopMatch m, Case)
| Const _ => empty ()
| Constraint (e, t) => do2 (loop e, loopTy (t, d), Constraint)
| FlatApp es => doVec (es, FlatApp)
| Fn m => do1 (loopMatch m, Fn)
| Handle (e, m) => do2 (loop e, loopMatch m, Handle)
| If (e1, e2, e3) => do3 (loop e1, loop e2, loop e3, If)
| Let (dec, e) => do2 (loopDec (dec, d), loop e, Let)
| List ts => doList (ts, List)
| Orelse (e1, e2) => do2 (loop e1, loop e2, Orelse)
| Prim {kind, name, ty} =>
do1 (loopTy (ty, d), fn ty =>
Prim {kind = kind,
name = name,
ty = ty})
| Raise {exn, filePos} =>
do1 (loop exn,
fn exn => Raise {exn = exn, filePos = filePos})
| Record r =>
let
val (r, u) = Record.change (r, fn es =>
loops (es, loop))
in
(doit (Record r), u)
end
| Selector _ => empty ()
| Seq es => doVec (es, Seq)
| Var _ => empty ()
| While {expr, test} =>
do2 (loop expr, loop test, fn (expr, test) =>
While {expr = expr, test = test})
end
in
loop e
end
and loopMatch (Match.T {filePos, rules}, d) =
let
val (rules, u) =
loops (rules, fn (p, e) =>
let
val (p, u) = loopPat (p, d)
val (e, u') = loopExp (e, d)
in
((p, e), combineUp (u, u'))
end)
in
(Match.T {filePos = filePos, rules = rules}, u)
end
in
loopDec (d, initDown)
end
fun scope (dec: Dec.t): Dec.t =
let
fun bind (env, tyvars) =
let
val (env, tyvars) = Env.rename (env, tyvars)
fun finish u = Tyvars.- (u, Tyvars.fromList (Vector.toList tyvars))
in
(env, tyvars, finish)
end
fun bind' (env, tyvars) =
let
val (env, tyvars) = Env.rename (env, tyvars)
fun finish u =
(Vector.fromList
(Tyvars.toList
(Tyvars.+ (u, Tyvars.fromList (Vector.toList tyvars)))),
Tyvars.empty)
in
(env, finish)
end
fun tyvar (a, env) =
let
val a =
case Env.peek (env, a) of
NONE => a
| SOME a => a
in
(a, Tyvars.singleton a)
end
val (dec, unguarded) =
processDec (dec, {bind = bind,
bind' = bind',
combineUp = Tyvars.+,
initDown = Env.empty,
initUp = Tyvars.empty,
tyvar = tyvar})
in
if Tyvars.isEmpty unguarded
then
let
fun bind (env, tyvars) =
let
val (env, tyvars) = Env.rename (env, tyvars)
in
(env, tyvars, fn () => ())
end
fun bind' (env, tyvars) =
let
val (env, tyvars) =
Env.rename
(env,
Vector.fromList
(Tyvars.toList
(Tyvars.- (Tyvars.fromList (Vector.toList tyvars),
Tyvars.fromList (Env.domain env)))))
in
(env, fn () => (tyvars, ()))
end
fun tyvar (a, env) = (Env.lookup (env, a), ())
val (dec, ()) =
processDec (dec, {bind = bind,
bind' = bind',
combineUp = fn ((), ()) => (),
initDown = Env.empty,
initUp = (),
tyvar = tyvar})
in
dec
end
else
let
open Layout
val _ =
Control.error (Dec.region dec,
seq [str "free type variables: ",
List.layout Tyvar.layout
(Tyvars.toList unguarded)],
empty)
in
dec
end
end
val scope = Trace.trace ("scope", Dec.layout, Dec.layout) scope
end
1.1 mlton/mlton/elaborate/scope.sig
Index: scope.sig
===================================================================
(* Copyright (C) 1999-2003 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
signature SCOPE_STRUCTS =
sig
structure Ast: AST
end
signature SCOPE =
sig
include SCOPE_STRUCTS
(* Add free type variables to the val or fun declaration where they are
* implicitly scoped.
*)
val scope: Ast.Dec.t -> Ast.Dec.t
end
1.26 +1 -2 mlton/mlton/type-inference/infer.fun
Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- infer.fun 20 Jul 2003 18:07:58 -0000 1.25
+++ infer.fun 21 Jul 2003 21:53:50 -0000 1.26
@@ -16,7 +16,6 @@
structure Srecord = SortedRecord
structure Field = Record.Field
-structure Scope = Scope (structure CoreML = CoreML)
structure Env = TypeEnv (open CoreML
structure XmlType = Xml.Type)
structure Scheme = Env.InferScheme
@@ -1248,7 +1247,7 @@
(*------------------------------------*)
(* main code for type inference *)
(*------------------------------------*)
- val Cprogram.T {decs} = Scope.scope p
+ val Cprogram.T {decs} = p
val _ = Control.checkForErrors "type variable scope inference"
val (ds, env) =
Control.trace (Control.Pass, "unification")
1.4 +0 -2 mlton/mlton/type-inference/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 16 Apr 2002 12:10:53 -0000 1.3
+++ sources.cm 21 Jul 2003 21:53:50 -0000 1.4
@@ -23,7 +23,5 @@
match-compile.sig
nested-pat.fun
nested-pat.sig
-scope.fun
-scope.sig
type-env.fun
type-env.sig
-------------------------------------------------------
This SF.net email is sponsored by: VM Ware
With VMware you can run multiple operating systems on a single machine.
WITHOUT REBOOTING! Mix Linux / Windows / Novell virtual machines at the
same time. Free trial click here: http://www.vmware.com/wl/offer/345/0
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel