[MLton] cvs commit: new front end
sweeks@mlton.org
sweeks@mlton.org
Thu, 6 Nov 2003 16:21:29 -0800
sweeks 03/11/06 16:21:29
Modified: basis-library/arrays-and-vectors array.sig mono-vector.fun
basis-library/general bool.sml
basis-library/libs/basis-2002/top-level basis.sig
mlton Makefile mlton-stubs.cm
mlton/ast admits-equality.fun admits-equality.sig ast.fun
ast.sig record.fun record.sig tycon-kind.fun
tycon-kind.sig
mlton/elaborate elaborate-core.fun elaborate-env.fun
elaborate-env.sig elaborate-sigexp.fun sources.cm
type-env.fun type-env.sig
mlton/front-end ml.grm
mlton/main compile.fun main.fun main.sml
regression where.sml
Added: mlton/elaborate interface.fun interface.sig type-str.fun
type-str.sig
Log:
The next step towards a new front end: elaboration of signatures.
This involved adding in some old code that was ripped out a couple of
years ago to handle the representation of signatures. This lives in
elaborate/interface.{fun.sig}. The main trick is to use disjoint
sets to efficiently handle sharing of tycons and of structures and
then to copy signatures as dags rather than as trees.
There were a couple of fixes to make the basis library SML so that it
works with the new elaborator. There was even one fix to MLton itself
-- in the x86 codegen there was a type definition in a signature that
was being shared. SML/NJ allowed it, but the Definition (and hence
MLton) does not.
There is still one case that the signature elaborator doesn't get
right. It is pretty obscure -- have a look at regression/where.sml if
you want to see it.
Signature elaboration has slowed down MLton type checking itself, but
not too badly --- to lex, parse, and type check MLton takes about 13s
on my machine.
There are still several things that need doing before the front end
meets the Definition.
1. Check that value declarations in structures match the
specifications in signatures.
2. Opaque matching needs to hide type information.
3. Functors need to be checked at the point of definition, instead of
at each application.
And of course, there still needs to be lots of work on error messages,
both for the new signature, as well as for the core. Although I am
pretty much now developing exclusively with MLton type checking itself
and I am really liking the _ messages.
Revision Changes Path
1.8 +1 -1 mlton/basis-library/arrays-and-vectors/array.sig
Index: array.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/array.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- array.sig 5 Sep 2003 23:01:00 -0000 1.7
+++ array.sig 7 Nov 2003 00:21:26 -0000 1.8
@@ -1,6 +1,6 @@
signature ARRAY_GLOBAL =
sig
- type 'a array = 'a array
+ type 'a array = 'a Array.array
end
signature ARRAY =
1.4 +4 -4 mlton/basis-library/arrays-and-vectors/mono-vector.fun
Index: mono-vector.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/mono-vector.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- mono-vector.fun 5 Sep 2003 23:01:00 -0000 1.3
+++ mono-vector.fun 7 Nov 2003 00:21:26 -0000 1.4
@@ -5,8 +5,8 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor MonoVector(type elem): MONO_VECTOR_EXTRA
- where type elem = elem =
+functor MonoVector (type elem): MONO_VECTOR_EXTRA
+ where type elem = elem =
struct
open Vector
type elem = elem
@@ -20,8 +20,8 @@
end
end
-functor EqtypeMonoVector(eqtype elem): EQTYPE_MONO_VECTOR_EXTRA
- where type elem = elem =
+functor EqtypeMonoVector (eqtype elem): EQTYPE_MONO_VECTOR_EXTRA
+ where type elem = elem =
struct
open Vector
type elem = elem
1.6 +1 -0 mlton/basis-library/general/bool.sml
Index: bool.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/bool.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- bool.sml 24 Nov 2002 01:19:35 -0000 1.5
+++ bool.sml 7 Nov 2003 00:21:27 -0000 1.6
@@ -35,3 +35,4 @@
structure BoolGlobal: BOOL_GLOBAL = Bool
open BoolGlobal
+
1.20 +7 -3 mlton/basis-library/libs/basis-2002/top-level/basis.sig
Index: basis.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sig,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- basis.sig 11 Sep 2003 00:51:06 -0000 1.19
+++ basis.sig 7 Nov 2003 00:21:27 -0000 1.20
@@ -9,7 +9,7 @@
eqtype string
type substring
type exn
- eqtype 'a array
+ eqtype 'a array
eqtype 'a vector
(*
eqtype 'a ref
@@ -269,8 +269,11 @@
sharing type string = String.string
sharing type substring = Substring.substring
sharing type exn = General.exn
- sharing type array = Array.array
- sharing type vector = Vector.vector
+(* Can't use sharing on type array or vector, because they are rigid tycons.
+ * Don't need it anyways, since it's built into the ARRAY and VECTOR signatures.
+ *)
+(* sharing type array = Array.array *)
+(* sharing type vector = Vector.vector *)
(*
sharing type ref = General.ref
*)
@@ -546,6 +549,7 @@
where type OS.Process.status = OS.Process.status
where type Position.int = Position.int
where type Posix.Process.pid = Posix.Process.pid
+ where type Real64.real = Real64.real
where type StringCvt.radix = StringCvt.radix
where type StringCvt.realfmt = StringCvt.realfmt
(*
1.79 +1 -1 mlton/mlton/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/Makefile,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -r1.78 -r1.79
--- Makefile 9 Oct 2003 18:00:51 -0000 1.78
+++ Makefile 7 Nov 2003 00:21:27 -0000 1.79
@@ -29,7 +29,7 @@
FLAGS += -host $(TARGET)
endif
ifeq (new,$(shell PATH=$(BIN):$$PATH; mlton -verbose 1 >/dev/null 2>&1 && echo new))
- FLAGS += -verbose 1 -output $(AOUT)
+ FLAGS += -verbose 2 -output $(AOUT)
else
FLAGS += -v -o $(AOUT)
endif
1.36 +5 -1 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- mlton-stubs.cm 3 Nov 2003 06:40:03 -0000 1.35
+++ mlton-stubs.cm 7 Nov 2003 00:21:27 -0000 1.36
@@ -168,7 +168,6 @@
atoms/type.fun
atoms/generic-scheme.sig
atoms/scheme.sig
-atoms/generic-scheme.fun
atoms/word-x.sig
atoms/var.sig
atoms/source-info.sig
@@ -485,9 +484,14 @@
elaborate/type-env.sig
elaborate/type-env.fun
elaborate/decs.sig
+elaborate/type-str.sig
+elaborate/interface.sig
elaborate/elaborate-env.sig
elaborate/const-type.sig
elaborate/elaborate.sig
+elaborate/type-str.fun
+atoms/generic-scheme.fun
+elaborate/interface.fun
elaborate/decs.fun
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
1.2 +7 -0 mlton/mlton/ast/admits-equality.fun
Index: admits-equality.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/admits-equality.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- admits-equality.fun 16 Oct 2003 22:37:12 -0000 1.1
+++ admits-equality.fun 7 Nov 2003 00:21:27 -0000 1.2
@@ -12,4 +12,11 @@
val layout = Layout.str o toString
+val or =
+ fn (Always, _) => Always
+ | (_, Always) => Always
+ | (Sometimes, _) => Sometimes
+ | (_, Sometimes) => Sometimes
+ | _ => Never
+
end
1.2 +1 -0 mlton/mlton/ast/admits-equality.sig
Index: admits-equality.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/admits-equality.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- admits-equality.sig 16 Oct 2003 22:37:12 -0000 1.1
+++ admits-equality.sig 7 Nov 2003 00:21:28 -0000 1.2
@@ -9,5 +9,6 @@
datatype t = Always | Never | Sometimes
val layout: t -> Layout.t
+ val or: t * t -> t
val toString: t -> string
end
1.8 +28 -24 mlton/mlton/ast/ast.fun
Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- ast.fun 9 Oct 2003 18:17:30 -0000 1.7
+++ ast.fun 7 Nov 2003 00:21:28 -0000 1.8
@@ -63,18 +63,18 @@
| Transparent of sigexp
| Opaque of sigexp
and specNode =
- Empty
- | Seq of spec * spec
- | Structure of (Strid.t * sigexp) list
- | Type of typedescs
- | TypeDefs of typedefs
+ Datatype of DatatypeRhs.t
+ | Empty
| Eqtype of typedescs
- | Val of (Var.t * Type.t) list
- | Datatype of DatatypeRhs.t
| Exception of (Con.t * Type.t option) list
| IncludeSigexp of sigexp
| IncludeSigids of Sigid.t list
+ | Seq of spec * spec
| Sharing of {spec: spec, equations: Equation.t list}
+ | Structure of (Strid.t * sigexp) list
+ | Type of typedescs
+ | TypeDefs of TypBind.t
+ | Val of (Var.t * Type.t) list
withtype spec = specNode Wrap.t
and sigexp = sigexpNode Wrap.t
@@ -83,11 +83,15 @@
seq [prefix,
Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout)])
-fun layoutTypedefs (prefix, typedescs) =
- layoutAnds (prefix, typedescs, fn (prefix, {tyvars, tycon, ty}) =>
- seq [prefix,
- Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout),
- str " = ", Type.layout ty])
+fun layoutTypedefs (prefix, typBind) =
+ let
+ val TypBind.T l = TypBind.node typBind
+ in
+ layoutAnds (prefix, l, fn (prefix, {def, tycon, tyvars}) =>
+ seq [prefix,
+ Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout),
+ str " = ", Type.layout def])
+ end
fun layoutSigexp (e: sigexp): Layout.t =
case node e of
@@ -195,18 +199,19 @@
(*---------------------------------------------------*)
datatype strdecNode =
- Structure of {name: Strid.t,
- def: strexp,
- constraint: SigConst.t} list
+ Core of Dec.t
| Local of strdec * strdec
| Seq of strdec list
- | Core of Dec.t
+ | Structure of {name: Strid.t,
+ def: strexp,
+ constraint: SigConst.t} list
+
and strexpNode =
- Var of Longstrid.t
- | Struct of strdec
+ App of Fctid.t * strexp
| Constrained of strexp * SigConst.t
- | App of Fctid.t * strexp
| Let of strdec * strexp
+ | Struct of strdec
+ | Var of Longstrid.t
withtype strexp = strexpNode Wrap.t
and strdec = strdecNode Wrap.t
@@ -227,14 +232,13 @@
and layoutStrexp exp =
case node exp of
- Var s => Longstrid.layout s
+ App (f, e) => seq [Fctid.layout f, str " ", paren (layoutStrexp e)]
+ | Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c]
+ | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp)
| Struct d => align [str "struct",
indent (layoutStrdec d, 3),
str "end"]
- | Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c]
- | App (f, e) =>
- seq [Fctid.layout f, str "(", layoutStrexp e, str ")"]
- | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp)
+ | Var s => Longstrid.layout s
structure Strexp =
struct
1.5 +16 -18 mlton/mlton/ast/ast.sig
Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ast.sig 9 Oct 2003 18:17:30 -0000 1.4
+++ ast.sig 7 Nov 2003 00:21:28 -0000 1.5
@@ -23,11 +23,11 @@
type t
datatype node =
- Var of Sigid.t
+ Spec of spec
+ | Var of Sigid.t
| Where of t * {tyvars: Tyvar.t vector,
longtycon: Longtycon.t,
ty: Type.t} list
- | Spec of spec
include WRAPPED sharing type node' = node
sharing type obj = t
@@ -45,16 +45,16 @@
sig
datatype t =
None
- | Transparent of Sigexp.t
| Opaque of Sigexp.t
+ | Transparent of Sigexp.t
end
structure Equation:
sig
type t
datatype node =
- Type of Longtycon.t list
- | Structure of Longstrid.t list
+ Structure of Longstrid.t list
+ | Type of Longtycon.t list
include WRAPPED sharing type node' = node
sharing type obj = t
end
@@ -63,23 +63,21 @@
sig
type t
datatype node =
- Val of (Var.t * Type.t) list
- | Type of {tyvars: Tyvar.t vector,
- tycon: Tycon.t} list
- | TypeDefs of {tyvars: Tyvar.t vector,
- tycon: Tycon.t,
- ty: Type.t} list
- | Eqtype of {tyvars: Tyvar.t vector,
- tycon: Tycon.t} list
- | Datatype of DatatypeRhs.t
+ Datatype of DatatypeRhs.t
+ | Eqtype of {tycon: Tycon.t,
+ tyvars: Tyvar.t vector} list
+ | Empty
| Exception of (Con.t * Type.t option) list
- | Structure of (Strid.t * Sigexp.t) list
| IncludeSigexp of Sigexp.t
| IncludeSigids of Sigid.t list
- | Empty
| Seq of t * t
- | Sharing of {spec: t,
- equations: Equation.t list}
+ | Sharing of {equations: Equation.t list,
+ spec: t}
+ | Structure of (Strid.t * Sigexp.t) list
+ | Type of {tycon: Tycon.t,
+ tyvars: Tyvar.t vector} list
+ | TypeDefs of TypBind.t
+ | Val of (Var.t * Type.t) list
include WRAPPED sharing type node' = node
sharing type obj = t
1.7 +2 -0 mlton/mlton/ast/record.fun
Index: record.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- record.fun 10 Oct 2003 00:11:04 -0000 1.6
+++ record.fun 7 Nov 2003 00:21:28 -0000 1.7
@@ -86,6 +86,8 @@
Tuple xs => Vector.exists (xs, p)
| Record r => Vector.exists (r, fn (_, x) => p x)
+fun forall (r, p) = not (exists (r, not o p))
+
fun foldi (r, b, f) =
case r of
Tuple xs => Vector.foldi (xs, b, fn (i, x, b) => f (Field.Int i, x, b))
1.4 +1 -0 mlton/mlton/ast/record.sig
Index: record.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- record.sig 23 Jun 2003 04:58:55 -0000 1.3
+++ record.sig 7 Nov 2003 00:21:28 -0000 1.4
@@ -27,6 +27,7 @@
val exists: 'a t * ('a -> bool) -> bool
val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
val foldi: 'a t * 'b * (Field.t * 'a * 'b ->'b) -> 'b
+ val forall: 'a t * ('a -> bool) -> bool
val foreach: 'a t * ('a -> unit) -> unit
val fromVector: (Field.t * 'a) vector -> 'a t
val isTuple: 'a t -> bool
1.2 +5 -0 mlton/mlton/ast/tycon-kind.fun
Index: tycon-kind.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/tycon-kind.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- tycon-kind.fun 9 Oct 2003 18:17:30 -0000 1.1
+++ tycon-kind.fun 7 Nov 2003 00:21:28 -0000 1.2
@@ -10,6 +10,11 @@
val layout =
fn Arity n => Int.layout n
| Nary => Layout.str "n-ary"
+
+val equals =
+ fn (Arity n, Arity n') => n = n'
+ | (Nary, Nary) => true
+ | _ => false
end
1.2 +1 -0 mlton/mlton/ast/tycon-kind.sig
Index: tycon-kind.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/tycon-kind.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- tycon-kind.sig 9 Oct 2003 18:17:30 -0000 1.1
+++ tycon-kind.sig 7 Nov 2003 00:21:28 -0000 1.2
@@ -12,5 +12,6 @@
Arity of int
| Nary
+ val equals: t * t -> bool
val layout: t -> Layout.t
end
1.43 +11 -15 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- elaborate-core.fun 18 Oct 2003 16:20:07 -0000 1.42
+++ elaborate-core.fun 7 Nov 2003 00:21:28 -0000 1.43
@@ -42,7 +42,12 @@
structure Vid = Vid
end
-structure Kind = TypeStr.Kind
+local
+ open TypeStr
+in
+ structure Cons = Cons
+ structure Kind = Kind
+end
local
open TypeEnv
@@ -263,16 +268,8 @@
val str = str
end
-fun unify (t1: Type.t, t2: Type.t,
- f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t): unit =
- let
- datatype z = datatype Type.unifyResult
- in
- case Type.unify (t1, t2) of
- NotUnifiable z => Control.error (f z)
- | Unified => ()
- end
-
+val unify = Type.unify
+
fun unifyList (trs: (Type.t * Region.t) vector,
lay: unit -> Layout.t): Type.t =
if 0 = Vector.length trs
@@ -847,7 +844,6 @@
fun elabTypeOpt t = elaborateTypeOpt (t, Lookup.fromEnv E)
fun elabTypBind (typBind: TypBind.t) =
let
- val lookup = Lookup.fromEnv E
val TypBind.T types = TypBind.node typBind
val strs =
List.map
@@ -867,7 +863,6 @@
(* rules 28, 29, 81, 82 *)
let
val region = DatBind.region datBind
- val lookup = Lookup.fromEnv E
val DatBind.T {datatypes, withtypes} = DatBind.node datBind
(* Build enough of an env so that that the withtypes and the
* constructor argument types can be elaborated.
@@ -945,7 +940,7 @@
val typeStr =
TypeStr.data (tycon,
Kind.Arity (Vector.length tyvars),
- cons)
+ Cons.T cons)
val _ = Env.extendTycon (E, astTycon, typeStr)
in
({cons = datatypeCons,
@@ -1024,9 +1019,10 @@
let
val tyStr = Env.lookupLongtycon (E, rhs)
val _ = Env.extendTycon (E, lhs, tyStr)
+ val TypeStr.Cons.T v = TypeStr.cons tyStr
val _ =
Vector.foreach
- (TypeStr.cons tyStr, fn {con, name, scheme} =>
+ (v, fn {con, name, scheme} =>
Env.extendCon (E, name, con, scheme))
in
Decs.empty
1.17 +329 -484 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- elaborate-env.fun 16 Oct 2003 22:37:12 -0000 1.16
+++ elaborate-env.fun 7 Nov 2003 00:21:28 -0000 1.17
@@ -28,12 +28,14 @@
structure Var = Var
structure Prim = Prim
structure Record = Record
- structure Srecord = SortedRecord
+ structure SortedRecord = SortedRecord
structure Tycon = Tycon
structure Tyvar = Tyvar
structure Var = Var
end
+structure Kind = Tycon.Kind
+
local
open TypeEnv
in
@@ -53,79 +55,6 @@
structure TypeScheme = Scheme
structure Scope = UniqueId ()
-
-structure TypeStr =
- struct
- structure Kind = CoreML.Tycon.Kind
-
- datatype node =
- Datatype of {cons: {con: Con.t,
- name: Ast.Con.t,
- scheme: Scheme.t} vector,
- tycon: Tycon.t}
- | Scheme of Scheme.t
- | Tycon of Tycon.t
-
- datatype t = T of {kind: Kind.t,
- node: node}
-
- local
- fun make f (T r) = f r
- in
- val kind = make #kind
- val node = make #node
- end
-
- fun bogus () =
- T {kind = Kind.Arity 0,
- node = Scheme (Scheme.bogus ())}
-
- fun abs t =
- case node t of
- Datatype {tycon, ...} => T {kind = kind t,
- node = Tycon tycon}
- | _ => t
-
- fun apply (t: t, tys: Type.t vector): Type.t =
- case node t of
- Datatype {tycon, ...} => Type.con (tycon, tys)
- | Scheme s => Scheme.apply (s, tys)
- | Tycon t => Type.con (t, tys)
-
- fun cons t =
- case node t of
- Datatype {cons, ...} => cons
- | _ => Vector.new0 ()
-
- fun data (tycon, kind, cons) =
- T {kind = kind,
- node = Datatype {tycon = tycon, cons = cons}}
-
- fun def (s, kind) = T {kind = kind,
- node = Scheme s}
-
- fun tycon (c, kind) = T {kind = kind,
- node = Tycon c}
-
- fun layout t =
- let
- open Layout
- in
- case node t of
- Datatype {tycon, cons} =>
- seq [str "Datatype ",
- record [("tycon", Tycon.layout tycon),
- ("cons", (Vector.layout
- (fn {con, name, scheme} =>
- tuple [Ast.Con.layout name,
- Con.layout con,
- str ": ",
- Scheme.layout scheme])
- cons))]]
- | Scheme s => Scheme.layout s
- | Tycon t => seq [str "Tycon ", Tycon.layout t]
- end
- end
structure Vid =
struct
@@ -215,124 +144,100 @@
fn T {ranges, ...} => List.pop ranges
end
-structure ShapeId = UniqueId ()
-
-structure Status:
- sig
- datatype t = Con | Exn | Var
-
- val layout: t -> Layout.t
- val toString: t -> string
- end =
- struct
- datatype t = Con | Exn | Var
-
- val toString =
- fn Con => "Con"
- | Exn => "Exn"
- | Var => "Var"
+structure TypeStr = TypeStr (structure Con = Con
+ structure Kind = Tycon.Kind
+ structure Name = Ast.Con
+ structure Record = SortedRecord
+ structure Scheme =
+ struct
+ open Scheme
+
+ val make =
+ fn (tyvars, ty) =>
+ make {canGeneralize = true,
+ ty = ty,
+ tyvars = tyvars}
+ end
+ structure Tycon =
+ struct
+ open Tycon
+
+ val admitsEquality =
+ TypeEnv.tyconAdmitsEquality
+
+ val make = newNoname
+ end
+ structure Type =
+ struct
+ open Type
+
+ val bogus = new ()
+ end
+ structure Tyvar = Tyvar)
- val layout = Layout.str o toString
- end
+structure Interface = Interface (structure Ast = Ast
+ structure EnvTypeStr = TypeStr)
-(* ------------------------------------------------- *)
-(* Interface *)
-(* ------------------------------------------------- *)
+local
+ open Interface
+in
+ structure ShapeId = ShapeId
+ structure Status = Status
+end
-structure Interface =
+structure Info =
struct
- structure Info =
- struct
- (* The array is sorted by domain element. *)
- datatype ('a, 'b) t = T of {isUsed: bool ref,
- range: 'b,
- values: ('a, 'b) Values.t} array
-
- fun bogus () = T (Array.tabulate (0, fn _ => Error.bug "impossible"))
-
- fun layout (layoutDomain, layoutRange) (T a) =
- Array.layout (fn {range, values, ...} =>
- Layout.tuple [layoutDomain (Values.domain values),
- layoutRange range])
- a
-
- fun foreach (T a, f) =
- Array.foreach (a, fn {range, values, ...} =>
- f (Values.domain values, range))
-
- fun peek (T a, compare, domain) =
- Option.map
- (BinarySearch.search
- (a, fn {values, ...} => compare (domain, Values.domain values)),
- fn i =>
- let
- val v as {isUsed, ...} = Array.sub (a, i)
- val _ = isUsed := !Control.showBasisUsed
- in
- v
- end)
- end
-
- structure TypeStr =
- struct
- datatype t =
- Datatype of {cons: Ast.Con.t vector}
- | Tycon
-
- val cons =
- fn Datatype {cons, ...} => cons
- | Tycon => Vector.new0 ()
-
- fun layout t =
- let
- open Layout
- in
- case t of
- Datatype {cons, ...} =>
- seq [str "Datatype ", Vector.layout Ast.Con.layout cons]
- | Tycon => str "Tycon"
- end
- end
-
- datatype t = T of {id: ShapeId.t,
- strs: (Ast.Strid.t, t) Info.t,
- vals: (Ast.Vid.t, Status.t) Info.t,
- types: (Ast.Tycon.t, TypeStr.t) Info.t}
-
- local
- fun make (field, compare) (T fields, domain) =
- Option.map (Info.peek (field fields, compare, domain), #range)
- in
- val peekStrid = make (#strs, Ast.Strid.compare)
- val peekTycon = make (#types, Ast.Tycon.compare)
- end
-
- fun peekStrids (I: t, strids: Ast.Strid.t list): t option =
- case strids of
- [] => SOME I
- | s :: strids =>
- case peekStrid (I, s) of
- NONE => NONE
- | SOME I => peekStrids (I, strids)
-
- val bogus = T {id = ShapeId.new (),
- strs = Info.bogus (),
- vals = Info.bogus (),
- types = Info.bogus ()}
-
- fun layout (T {strs, vals, types, ...}) =
- Layout.record
- [("strs", Info.layout (Ast.Strid.layout, layout) strs),
- ("vals", Info.layout (Ast.Vid.layout, Status.layout) vals),
- ("types", Info.layout (Ast.Tycon.layout, TypeStr.layout) types)]
-
- fun shapeId (T {id, ...}) = id
-
- fun foreach (T {strs, vals, types, ...},
- {handleStr, handleType, handleVal}) =
- (Info.foreach (strs, handleStr)
- ; Info.foreach (vals, handleVal)
- ; Info.foreach (types, handleType))
+ (* The array is sorted by domain element. *)
+ datatype ('a, 'b) t = T of {isUsed: bool ref,
+ range: 'b,
+ values: ('a, 'b) Values.t} array
+
+ fun bogus () = T (Array.tabulate (0, fn _ => Error.bug "impossible"))
+
+ fun layout (layoutDomain, layoutRange) (T a) =
+ Array.layout (fn {range, values, ...} =>
+ Layout.tuple [layoutDomain (Values.domain values),
+ layoutRange range])
+ a
+
+ fun foreach (T a, f) =
+ Array.foreach (a, fn {range, values, ...} =>
+ f (Values.domain values, range))
+
+ fun peek (T a, compare, domain) =
+ Option.map
+ (BinarySearch.search
+ (a, fn {values, ...} => compare (domain, Values.domain values)),
+ fn i =>
+ let
+ val v as {isUsed, ...} = Array.sub (a, i)
+ val _ = isUsed := !Control.showBasisUsed
+ in
+ v
+ end)
+ end
+
+(* pre: arities are equal. *)
+fun equalSchemes (s: Scheme.t, s': Scheme.t, name: unit -> Layout.t, r: Region.t)
+ : unit =
+ let
+ val (tyvars, ty) = Scheme.dest s
+ val (_, ty') = Scheme.dest s'
+ val tyvars =
+ Vector.tabulate (Vector.length tyvars, fn _ =>
+ Type.var (Tyvar.newNoname {equality = false}))
+ in
+ Type.unify
+ (Scheme.apply (s, tyvars), Scheme.apply (s', tyvars), fn (l1, l2) =>
+ let
+ open Layout
+ in
+ (r,
+ seq [str "type ", name (),
+ str " in structure and signature disagree"],
+ align [seq [str "structure: ", l1],
+ seq [str "signature: ", l2]])
+ end)
end
(* ------------------------------------------------- *)
@@ -341,8 +246,6 @@
structure Structure =
struct
- structure Info = Interface.Info
-
datatype t = T of {shapeId: ShapeId.t option,
strs: (Ast.Strid.t, t) Info.t,
types: (Ast.Tycon.t, TypeStr.t) Info.t,
@@ -465,155 +368,252 @@
loop (S, strids, [])
end
-(* fun peekLongtycon (S, t) =
- * let
- * val (strids, t) = Ast.Longtycon.split t
- * in
- * case peekStrids (S, strids) of
- * NONE => NONE
- * | SOME S => peekTycon (S, t)
- * end
- *)
-
-(* val lookupLongtycon = valOf o peekLongtycon
- *
- *)
+ fun peekLongtycon (S, t): TypeStr.t option =
+ let
+ val (strids, t) = Ast.Longtycon.split t
+ in
+ case peekStrids (S, strids) of
+ Found S => peekTycon (S, t)
+ | UndefinedStructure _ => NONE
+ end
+
(* section 5.3, 5.5, 5.6 and rules 52, 53 *)
- fun cut {str, interface, opaque, region}: t =
+ fun cut {str, interface, opaque: bool, region}: t =
let
fun error (name, l) =
- Control.error
- (region, let open Layout
- in seq [str name, str " ", l,
- str " in signature but not in structure"]
- end, Layout.empty)
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str (concat [name, " "]), l,
+ str " in signature but not in structure"],
+ empty)
+ end
+ val interface =
+ Interface.realize
+ (interface, fn (c, k) =>
+ case peekLongtycon (str, c) of
+ NONE => (error ("type", Longtycon.layout c)
+ ; TypeStr.bogus k)
+ | SOME typeStr =>
+ let
+ val k' = TypeStr.kind typeStr
+ in
+ if Kind.equals (k, k')
+ then typeStr
+ else
+ let
+ open Layout
+ val _ =
+ Control.error
+ (Longtycon.region c,
+ seq [str "type ", Longtycon.layout c,
+ str "has arity ", Kind.layout k',
+ str "in structure but arity ",
+ Kind.layout k, str " in signature"],
+ empty)
+ in
+ TypeStr.bogus k
+ end
+ end)
fun cut (S as T {shapeId, ...}, I, strids) =
let
val shapeId' = Interface.shapeId I
- val cutoff =
- if opaque then NONE
- else case shapeId of
- NONE => NONE
- | SOME shapeId =>
- if ShapeId.equals (shapeId, shapeId')
- then SOME S
- else NONE
- in
- case cutoff of
- SOME S => S
- | NONE =>
- let
- val strs = ref []
- val vals = ref []
- val types = ref []
- fun handleStr (name, I) =
- case peekStrid' (S, name) of
- NONE =>
- error
- ("structure",
- Longstrid.layout
- (Longstrid.long(rev strids, name)))
- | SOME {range, values, ...} =>
- List.push
- (strs,
- {isUsed = ref false,
- range = cut (range, I, name :: strids),
- values = values})
- fun handleType (name: Ast.Tycon.t,
- typeStr: Interface.TypeStr.t) =
+ fun doit () =
+ let
+ val strs = ref []
+ val vals = ref []
+ val types = ref []
+ fun handleStr {name, interface = I} =
+ case peekStrid' (S, name) of
+ NONE =>
+ error
+ ("structure",
+ Longstrid.layout
+ (Longstrid.long (rev strids, name)))
+ | SOME {range, values, ...} =>
+ List.push
+ (strs,
+ {isUsed = ref false,
+ range = cut (range, I, name :: strids),
+ values = values})
+ fun handleType {name: Ast.Tycon.t,
+ typeStr: TypeStr.t} =
+ let
+ fun layoutName () =
+ Longtycon.layout
+ (Longtycon.long (rev strids, name))
+ in
case peekTycon' (S, name) of
- NONE =>
- error
- ("type",
- Longtycon.layout
- (Longtycon.long (rev strids, name)))
+ NONE => error ("type", layoutName ())
| SOME {range = typeStr', values, ...} =>
let
+ fun tyconScheme (c: Tycon.t): Scheme.t =
+ let
+ val tyvars =
+ case TypeStr.kind typeStr' of
+ Kind.Arity n =>
+ Vector.tabulate
+ (n, fn _ =>
+ Tyvar.newNoname
+ {equality = false})
+ | _ => Error.bug "Nary tycon"
+ in
+ Scheme.make
+ {canGeneralize = true,
+ ty = Type.con (c, Vector.map (tyvars, Type.var)),
+ tyvars = tyvars}
+ end
datatype z = datatype TypeStr.node
- val typeStr'' =
- case typeStr of
- Interface.TypeStr.Datatype {cons} =>
- (case TypeStr.node typeStr' of
- Datatype _ => typeStr'
- | _ =>
- (Control.error
- (region,
- let open Layout
- in seq [str "type ",
- str " is a datatype in signature but not in structure"]
- end, Layout.empty)
- ; TypeStr.bogus ()))
- | Interface.TypeStr.Tycon =>
+ val k = TypeStr.kind typeStr
+ val k' = TypeStr.kind typeStr'
+ fun typeStrScheme (s: TypeStr.t) =
+ case TypeStr.node s of
+ Datatype {tycon, ...} =>
+ tyconScheme tycon
+ | Scheme s => s
+ | Tycon c' => tyconScheme c'
+ val typeStr =
+ if not (Kind.equals (k, k'))
+ then
let
- datatype z = datatype TypeStr.t
- in case TypeStr.node typeStr' of
- Datatype {tycon, ...} =>
- TypeStr.T
- {kind = TypeStr.kind typeStr',
- node = Tycon tycon}
- | _ => typeStr'
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str "type ", layoutName (),
+ str " has arity ", Kind.layout k',
+ str " in structure but arity ", Kind.layout k,
+ str " in signature"],
+ empty)
+ ; typeStr
end
- in List.push (types,
- {isUsed = ref false,
- range = typeStr'',
- values = values})
- end
- fun handleVal (name, status) =
- case peekVid' (S, name) of
- NONE =>
- error ("variable",
- Longvid.layout (Longvid.long
- (rev strids, name)))
- | SOME {range = (vid, s), values, ...} =>
- let
- val vid =
- case (vid, status) of
- (Vid.Con c, Status.Var) =>
- Vid.ConAsVar c
- | (Vid.Exn c, Status.Var) =>
- Vid.ConAsVar c
- | (_, Status.Var) => vid
- | (Vid.Con _, Status.Con) => vid
- | (Vid.Exn _, Status.Exn) => vid
- | _ =>
- (Control.error
- (region,
- Layout.str
- (concat
- ["identifier ",
- Longvid.toString
- (Longvid.long (rev strids,
- name)),
- " has status ",
- Vid.statusString vid,
- " in structure but status ",
- Status.toString status,
- " in signature "]),
- Layout.empty)
- ; vid)
+ else
+ case TypeStr.node typeStr of
+ Datatype _ =>
+ (case TypeStr.node typeStr' of
+ Datatype _ =>
+ (* need to match they cons in the structure against the signature *)
+ typeStr'
+ | _ =>
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str "type ",
+ layoutName (),
+ str " is a datatype in signature but not in structure"],
+ Layout.empty)
+ ; typeStr
+ end)
+ | Scheme s =>
+ (equalSchemes
+ (typeStrScheme typeStr',
+ s, layoutName, region)
+ ; typeStr)
+ | Tycon c =>
+ (equalSchemes
+ (typeStrScheme typeStr',
+ tyconScheme c,
+ layoutName, region)
+ ; typeStr)
in
- List.push (vals,
+ List.push (types,
{isUsed = ref false,
- range = (vid, s),
+ range = typeStr,
values = values})
end
- val _ =
- Interface.foreach
- (I, {handleStr = handleStr,
- handleType = handleType,
- handleVal = handleVal})
- fun doit (elts, less) =
- Info.T
- (QuickSort.sortArray
- (Array.fromList (!elts),
- fn ({values = v, ...}, {values = v', ...}) =>
- less (Values.domain v, Values.domain v')))
- in
- T {shapeId = SOME shapeId',
- strs = doit (strs, Ast.Strid.<=),
- vals = doit (vals, Ast.Vid.<=),
- types = doit (types, Ast.Tycon.<=)}
- end
+ end
+ fun handleVal {name, scheme, status} =
+ case peekVid' (S, name) of
+ NONE =>
+ error ("variable",
+ Longvid.layout (Longvid.long
+ (rev strids, name)))
+ | SOME {range = (vid, s), values, ...} =>
+ let
+ val vid =
+ case (vid, status) of
+ (Vid.Con c, Status.Var) =>
+ Vid.ConAsVar c
+ | (Vid.Exn c, Status.Var) =>
+ Vid.ConAsVar c
+ | (_, Status.Var) => vid
+ | (Vid.Con _, Status.Con) => vid
+ | (Vid.Exn _, Status.Exn) => vid
+ | _ =>
+ (Control.error
+ (region,
+ Layout.str
+ (concat
+ ["identifier ",
+ Longvid.toString
+ (Longvid.long (rev strids,
+ name)),
+ " has status ",
+ Vid.statusString vid,
+ " in structure but status ",
+ Status.toString status,
+ " in signature "]),
+ Layout.empty)
+ ; vid)
+ in
+ List.push (vals,
+ {isUsed = ref false,
+ range = (vid, s),
+ values = values})
+ end
+ val handleStr =
+ Trace.trace ("handleStr",
+ Ast.Strid.layout o #name,
+ Unit.layout)
+ handleStr
+ val handleType =
+ Trace.trace ("handleType",
+ fn {name, typeStr} =>
+ Layout.record [("name",
+ Ast.Tycon.layout name),
+ ("typeStr",
+ TypeStr.layout typeStr)],
+ Unit.layout)
+ handleType
+ val handleVal =
+ Trace.trace ("handleVal",
+ Ast.Vid.layout o #name,
+ Unit.layout)
+ handleVal
+ val _ =
+ Interface.fold
+ (I, (), fn (e, ()) =>
+ let
+ datatype z = datatype Interface.Element.t
+ in
+ case e of
+ Str z => handleStr z
+ | Type z => handleType z
+ | Val z => handleVal z
+ end)
+ fun doit (elts, op <=) =
+ Info.T
+ (QuickSort.sortArray
+ (Array.fromList (!elts),
+ fn ({values = v, ...}, {values = v', ...}) =>
+ Values.domain v <= Values.domain v'))
+ in
+ T {shapeId = SOME shapeId',
+ strs = doit (strs, Ast.Strid.<=),
+ types = doit (types, Ast.Tycon.<=),
+ vals = doit (vals, Ast.Vid.<=)}
+ end
+ in
+ case shapeId of
+ NONE => doit ()
+ | SOME shapeId =>
+ if ShapeId.equals (shapeId, shapeId')
+ then S
+ else doit ()
end
in
cut (str, interface, [])
@@ -622,7 +622,8 @@
val cut =
Trace.trace ("cut",
fn {str, interface, ...} =>
- Layout.tuple [layout str, Interface.layout interface],
+ Layout.tuple [layoutPretty str,
+ Interface.layout interface],
layout)
cut
@@ -667,7 +668,7 @@
fun domain s = fold (s, [], fn (vs, ac) => Values.domain vs :: ac)
fun collect (T {current, ...}: ('a, 'b) t,
- le: 'a * 'a -> bool): unit -> ('a, 'b) Structure.Info.t =
+ le: 'a * 'a -> bool): unit -> ('a, 'b) Info.t =
let
val old = !current
val _ = current := []
@@ -690,7 +691,7 @@
fn ({values = v, ...}, {values = v', ...}) =>
le (Values.domain v, Values.domain v'))
in
- Structure.Info.T a
+ Info.T a
end
end
@@ -1113,7 +1114,7 @@
Ast.Longstrid.layout)
val lookupLongtycon =
make (peekLongtycon,
- TypeStr.bogus,
+ fn () => TypeStr.bogus Kind.Nary,
"type",
Ast.Longtycon.region,
Ast.Longtycon.layout)
@@ -1345,167 +1346,11 @@
types = types', ...}): unit =
let
val scope = !currentScope
- fun doit (info, Structure.Info.T a) =
+ fun doit (info, Info.T a) =
Array.foreach (a, fn z => NameSpace.update (info, scope, z))
in doit (strs, strs')
; doit (vals, vals')
; doit (types, types')
end
-(* ------------------------------------------------- *)
-(* InterfaceMaker *)
-(* ------------------------------------------------- *)
-
-structure Env =
- struct
- datatype t = datatype t
-
- val lookupLongtycon = lookupLongtycon
- end
-
-structure InterfaceMaker =
- struct
- structure NameSpace =
- struct
- open NameSpace
-
- fun update (T {current, ...}, scope, {isUsed, range, values}) =
- let
- val ranges = Values.ranges values
- fun new () =
- let
- val value = {isUsed = isUsed,
- scope = scope,
- value = range}
- in
- List.push (current, values)
- ; List.push (ranges, value)
- end
- in
- case !ranges of
- [] => new ()
- | {scope = scope', ...} :: l =>
- if Scope.equals (scope, scope')
- then Control.error (Region.bogus,
- Layout.str "duplicate spec",
- Layout.empty)
- else new ()
- end
- end
-
- datatype t = T of {currentScope: Scope.t ref,
- env: Env.t,
- strs: (Ast.Strid.t, Interface.t) NameSpace.t,
- types: (Ast.Tycon.t, Interface.TypeStr.t) NameSpace.t,
- vals: (Ast.Vid.t, Status.t) NameSpace.t}
-
- local
- fun make sel (T (fields as {currentScope, ...}), d, r) =
- let
- val info as NameSpace.T {equals, hash, table, ...} = sel fields
- in NameSpace.update
- (info, !currentScope,
- {isUsed = ref false,
- range = r,
- values =
- HashSet.lookupOrInsert (table, hash d,
- fn vs => equals (d, Values.domain vs),
- fn () => Values.new d)})
- end
- in
- val addStrid = make #strs
- val addTycon' = make #types
- val addVid = make #vals
- end
-
- fun addCon (m, c) = addVid (m, Ast.Vid.fromCon c, Status.Con)
- fun addExcon (m, c) = addVid (m, Ast.Vid.fromCon c, Status.Exn)
- fun addVar (m, x) = addVid (m, Ast.Vid.fromVar x, Status.Var)
- fun addTycon (m as T {env = Env.T {vals, ...}, ...}, tyc, cons) =
- let
-(* val cons =
- * List.revMap
- * (cons, fn c =>
- * {con = c,
- * values = NameSpace.values (vals, Ast.Vid.fromCon c)})
- *)
- in addTycon' (m, tyc,
- if Vector.isEmpty cons
- then Interface.TypeStr.Tycon
- else Interface.TypeStr.Datatype {cons = cons})
- ; Vector.foreach (cons, fn c => addCon (m, c))
- end
-
- fun includeInterface (T {currentScope, strs, types, vals, ...},
- Interface.T {strs = strs',
- types = types',
- vals = vals', ...}): unit =
- let
- val scope = !currentScope
- fun doit (info, Interface.Info.T a) =
- Array.foreach (a, fn z => NameSpace.update (info, scope, z))
- in doit (strs, strs')
- ; doit (vals, vals')
- ; doit (types, types')
- end
-
- fun lookupLongtycon (T {env, strs, types, ...},
- x): Ast.Con.t vector =
- let
- val unbound =
- fn () =>
- (unbound (Ast.Longtycon.region x,
- "type",
- Ast.Longtycon.layout x)
- ; Vector.new0 ())
- fun lookInEnv () =
- let
- val typeStr = Env.lookupLongtycon (env, x)
- in
- Vector.map (TypeStr.cons typeStr, #name)
- end
- val (strids, tycon) = Ast.Longtycon.split x
- in
- case strids of
- [] => (case NameSpace.peek (types, tycon) of
- NONE => lookInEnv ()
- | SOME typeStr => Interface.TypeStr.cons typeStr)
- | s :: strids =>
- (case NameSpace.peek (strs, s) of
- NONE => lookInEnv ()
- | SOME I =>
- (case Interface.peekStrids (I, strids) of
- NONE => unbound ()
- | SOME I =>
- case Interface.peekTycon (I, tycon) of
- NONE => unbound ()
- | SOME typeStr =>
- Interface.TypeStr.cons typeStr))
- end
-
- fun makeInterface (T {currentScope, strs, types, vals, ...}, make) =
- let
- val strs = NameSpace.collect (strs, Ast.Strid.<=)
- val types = NameSpace.collect (types, Ast.Tycon.<=)
- val vals = NameSpace.collect (vals, Ast.Vid.<=)
- val s0 = !currentScope
- val _ = currentScope := Scope.new ()
- val res = make ()
- val I = Interface.T {id = ShapeId.new (),
- strs = strs (),
- types = types (),
- vals = vals ()}
- val _ = currentScope := s0
- in (res, I)
- end
- end
-
-fun makeInterfaceMaker E =
- InterfaceMaker.T
- {currentScope = ref (Scope.new ()),
- env = E,
- strs = NameSpace.new let open Ast.Strid in (equals, hash) end,
- types = NameSpace.new let open Ast.Tycon in (equals, hash) end,
- vals = NameSpace.new let open Ast.Vid in (equals, hash) end}
-
end
1.9 +15 -40 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- elaborate-env.sig 10 Oct 2003 00:01:33 -0000 1.8
+++ elaborate-env.sig 7 Nov 2003 00:21:28 -0000 1.9
@@ -15,6 +15,7 @@
structure TypeEnv: TYPE_ENV
sharing Ast.Record = CoreML.Record
sharing Ast.SortedRecord = CoreML.SortedRecord
+ sharing Ast.Tyvar = CoreML.Tyvar
sharing CoreML.Atoms = TypeEnv.Atoms
sharing CoreML.Type = TypeEnv.Type
end
@@ -30,12 +31,12 @@
sig
type t
end
- sharing type Type.t = TypeEnv.Type.t
+ sharing Type = TypeEnv.Type
structure Scheme:
sig
type t
end
- sharing type Scheme.t = TypeEnv.Scheme.t
+ sharing Scheme = TypeEnv.Scheme
(* The value of a vid. This is used to distinguish between vids whose
* status cannot be determined at parse time.
*)
@@ -45,46 +46,21 @@
Con of CoreML.Con.t
| ConAsVar of CoreML.Con.t
| Exn of CoreML.Con.t
- | Overload of (CoreML.Var.t * TypeEnv.Type.t) vector
+ | Overload of (CoreML.Var.t * Type.t) vector
| Var of CoreML.Var.t
val layout: t -> Layout.t
end
- structure TypeStr:
- sig
- structure Kind: TYCON_KIND
- type t
-
- val abs: t -> t
- val apply: t * TypeEnv.Type.t vector -> TypeEnv.Type.t
- val cons: t -> {con: CoreML.Con.t,
- name: Ast.Con.t,
- scheme: Scheme.t} vector
- val data:
- CoreML.Tycon.t * Kind.t
- * {con: CoreML.Con.t,
- name: Ast.Con.t,
- scheme: Scheme.t} vector -> t
- val def: Scheme.t * Kind.t -> t
- val kind: t -> Kind.t
- val tycon: CoreML.Tycon.t * Kind.t -> t
- end
- structure Interface:
- sig
- type t
- end
- structure InterfaceMaker:
- sig
- type t
-
- val addVar: t * Ast.Var.t -> unit
- val addExcon: t * Ast.Con.t -> unit
- val addTycon: t * Ast.Tycon.t * Ast.Con.t vector -> unit
- val addStrid: t * Ast.Strid.t * Interface.t -> unit
- val includeInterface: t * Interface.t -> unit
- val lookupLongtycon: t * Ast.Longtycon.t -> Ast.Con.t vector
- val makeInterface: t * (unit -> 'a) -> 'a * Interface.t
- end
+ structure TypeStr: TYPE_STR
+ sharing TypeStr.Con = CoreML.Con
+ sharing TypeStr.Name = Ast.Con
+ sharing TypeStr.Scheme = Scheme
+ sharing TypeStr.Tycon = CoreML.Tycon
+ sharing TypeStr.Type = Type
+ sharing TypeStr.Tyvar = Ast.Tyvar
+ structure Interface: INTERFACE
+ sharing Interface.Ast = Ast
+ sharing Interface.EnvTypeStr = TypeStr
structure Structure:
sig
type t
@@ -123,7 +99,7 @@
val extendTycon: t * Ast.Tycon.t * TypeStr.t -> unit
val extendVar: t * Ast.Var.t * CoreML.Var.t * Scheme.t -> unit
val extendOverload:
- t * Ast.Var.t * (CoreML.Var.t * TypeEnv.Type.t) vector * Scheme.t
+ t * Ast.Var.t * (CoreML.Var.t * Type.t) vector * Scheme.t
-> unit
val functorClosure:
t * Interface.t * (Structure.t * string list -> Decs.t * Structure.t)
@@ -141,7 +117,6 @@
val lookupLongvar: t * Ast.Longvar.t -> CoreML.Var.t * Scheme.t
val lookupLongvid: t * Ast.Longvid.t -> Vid.t * Scheme.t
val lookupSigid: t * Ast.Sigid.t -> Interface.t
- val makeInterfaceMaker: t -> InterfaceMaker.t
val makeStructure: t * (unit -> 'a) -> 'a * Structure.t
(* openStructure (E, S) opens S in the environment E. *)
val openStructure: t * Structure.t -> unit
1.3 +399 -55 mlton/mlton/elaborate/elaborate-sigexp.fun
Index: elaborate-sigexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- elaborate-sigexp.fun 10 Apr 2002 07:02:20 -0000 1.2
+++ elaborate-sigexp.fun 7 Nov 2003 00:21:28 -0000 1.3
@@ -10,26 +10,282 @@
open S
-local open Ast
-in structure Atype = Type
+local
+ open Ast
+in
+ structure Atype = Type
structure DatBind = DatBind
structure DatatypeRhs = DatatypeRhs
structure Equation = Equation
structure Longstrid = Longstrid
structure Longtycon = Longtycon
structure Sigexp = Sigexp
+ structure SortedRecord = SortedRecord
structure Spec = Spec
structure Strid = Strid
+ structure TypBind = TypBind
+ structure Tyvar = Tyvar
end
local
open Env
in
structure Interface = Interface
- structure Maker = InterfaceMaker
end
-structure Set = DisjointSet
+structure Con = Env.CoreML.Con
+
+local
+ open Interface
+in
+ structure Status = Status
+ structure TypeStr = TypeStr
+end
+
+local
+ open TypeStr
+in
+ structure Cons = Cons
+ structure Kind = Kind
+ structure Scheme = Scheme
+ structure Tycon = Tycon
+ structure Type = Type
+end
+
+local
+ open Tycon
+in
+ structure AdmitsEquality = AdmitsEquality
+end
+
+fun lookupLongtycon (E: Env.t,
+ I: Interface.t,
+ c: Ast.Longtycon.t) =
+ case Interface.peekLongtycon (I, c) of
+ NONE => TypeStr.fromEnv (Env.lookupLongtycon (E, c))
+ | SOME s => s
+
+fun elaborateType (ty: Atype.t, E: Env.t, I: Interface.t)
+ : Tyvar.t vector * Type.t =
+ let
+ val tyvars = ref []
+ fun loop (ty: Atype.t): Type.t =
+ case Atype.node ty of
+ Atype.Var a => (* rule 44 *)
+ Type.var
+ (case List.peek (!tyvars, fn a' => Tyvar.sameName (a, a')) of
+ NONE => (List.push (tyvars, a); a)
+ | SOME a => a)
+ | Atype.Con (c, ts) => (* rules 46, 47 *)
+ let
+ val ts = Vector.map (ts, loop)
+ fun normal () =
+ let
+ val s = lookupLongtycon (E, I, c)
+ val kind = TypeStr.kind s
+ val numArgs = Vector.length ts
+ in
+ if (case kind of
+ Kind.Arity n => n = numArgs
+ | Kind.Nary => true)
+ then TypeStr.apply (s, ts)
+ else
+ let
+ open Layout
+ val _ =
+ Control.error
+ (Atype.region ty,
+ seq [str "type constructor ",
+ Ast.Longtycon.layout c,
+ str " given ",
+ Int.layout numArgs,
+ str " arguments but wants ",
+ Kind.layout kind],
+ empty)
+ in
+ Type.bogus
+ end
+ end
+ in
+ case (Ast.Longtycon.split c, Vector.length ts) of
+ (([], c), 2) =>
+ if Ast.Tycon.equals (c, Ast.Tycon.arrow)
+ then Type.arrow (Vector.sub (ts, 0),
+ Vector.sub (ts, 1))
+ else normal ()
+ | _ => normal ()
+ end
+ | Atype.Record r => (* rules 45, 49 *)
+ Type.record (SortedRecord.map (r, loop))
+ val ty = loop ty
+ in
+ (Vector.fromList (!tyvars), ty)
+ end
+
+val elaborateType =
+ Trace.trace ("elaborateType", Atype.layout o #1, Type.layout o #2)
+ elaborateType
+
+fun elaborateScheme (tyvars: Tyvar.t vector, ty: Atype.t, E, I): Scheme.t =
+ let
+ val (tyvars', ty) = elaborateType (ty, E, I)
+ val unbound =
+ Vector.keepAll
+ (tyvars', fn a =>
+ not (Vector.exists (tyvars, fn a' => Tyvar.sameName (a, a'))))
+ val _ =
+ if 0 = Vector.length unbound
+ then ()
+ else
+ let
+ open Layout
+ in
+ Control.error (Tyvar.region (Vector.sub (tyvars', 0)),
+ seq [str "unbound type variables: ",
+ seq (separate
+ (Vector.toListMap (unbound,
+ Tyvar.layout),
+ ", "))],
+ empty)
+ end
+ (* Need to get the representatives that were chosen when elaborating the
+ * type.
+ *)
+ val tyvars =
+ Vector.map
+ (tyvars, fn a =>
+ case Vector.peek (tyvars', fn a' => Tyvar.sameName (a, a')) of
+ NONE => a
+ | SOME a' => a')
+ in
+ Scheme.make (tyvars, ty)
+ end
+
+fun elaborateTypedescs (typedescs: {tycon: Ast.Tycon.t,
+ tyvars: Tyvar.t vector} list,
+ {equality: bool}): Interface.t =
+ Interface.types
+ (Vector.fromListMap
+ (typedescs, fn {tycon = name, tyvars} =>
+ let
+ val tycon = Tycon.make ()
+ val _ =
+ Tycon.admitsEquality tycon
+ := (if equality
+ then AdmitsEquality.Sometimes
+ else AdmitsEquality.Never)
+ in
+ {name = name,
+ typeStr = TypeStr.tycon (tycon, Kind.Arity (Vector.length tyvars))}
+ end))
+
+val elaborateTypedescs =
+ Trace.trace ("elaborateTypedescs", Layout.ignore, Interface.layout)
+ elaborateTypedescs
+
+
+fun elaborateDatBind (datBind: DatBind.t, E, I): Interface.t =
+ let
+ val region = DatBind.region datBind
+ val DatBind.T {datatypes, withtypes} = DatBind.node datBind
+ val change = ref false
+ (* Build enough of an interface so that that the withtypes and the
+ * constructor argument types can be elaborated.
+ *)
+ val (tycons, strs) =
+ Vector.unzip
+ (Vector.map
+ (datatypes, fn {cons, tycon = name, tyvars} =>
+ let
+ val tycon = Tycon.make ()
+ in
+ (tycon,
+ {name = name,
+ typeStr = TypeStr.data (tycon,
+ Kind.Arity (Vector.length tyvars),
+ Cons.empty)})
+ end))
+ val I' = Interface.types strs
+ fun elabAll (I1: Interface.t): Interface.t =
+ let
+ val I2 = Interface.+ (I1, I)
+ val Is =
+ Vector.map2
+ (tycons, datatypes,
+ fn (tycon, {cons, tycon = astTycon, tyvars, ...}) =>
+ let
+ val resultType: Type.t =
+ Type.con (tycon, Vector.map (tyvars, Type.var))
+ val (cons, conArgs) =
+ Vector.unzip
+ (Vector.map
+ (cons, fn (name, arg) =>
+ let
+ val con = Con.newNoname ()
+ val (arg, ty) =
+ case arg of
+ NONE => (NONE, resultType)
+ | SOME t =>
+ let
+ (* We do the elaborateScheme here to
+ * check for unbound tyvars in t.
+ *)
+ val t =
+ Scheme.ty
+ (elaborateScheme (tyvars, t, E, I2))
+ in
+ (SOME t, Type.arrow (t, resultType))
+ end
+ val scheme = Scheme.make (tyvars, ty)
+ in
+ ({con = con: TypeStr.Con.t, name = name, scheme = scheme},
+ arg)
+ end))
+ val cons = Cons.T cons
+ val _ =
+ let
+ val r = Tycon.admitsEquality tycon
+ datatype z = datatype AdmitsEquality.t
+ in
+ case !r of
+ Always => Error.bug "datatype Always"
+ | Never => ()
+ | Sometimes =>
+ if Vector.forall
+ (conArgs, fn arg =>
+ case arg of
+ NONE => true
+ | SOME ty =>
+ Scheme.admitsEquality
+ (Scheme.make (tyvars, ty)))
+ then ()
+ else (r := Never; change := true)
+ end
+ in
+ Interface.+
+ (Interface.cons cons,
+ Interface.types
+ (Vector.new1
+ {name = astTycon,
+ typeStr = TypeStr.data (tycon,
+ Kind.Arity (Vector.length tyvars),
+ cons)}))
+ end)
+ in
+ Vector.fold (Is, Interface.empty, Interface.+)
+ end
+ (* Maximize equality. *)
+ fun loop (I: Interface.t): Interface.t =
+ let
+ val I = elabAll I
+ in
+ if !change
+ then (change := false; loop I)
+ else I
+ end
+ in
+ loop I'
+ end
val info = Trace.info "elaborateSigexp"
val info' = Trace.info "elaborateSpec"
@@ -40,76 +296,164 @@
Sigexp.Var s => Env.lookupSigid (E, s)
| _ =>
let
- val m = Env.makeInterfaceMaker E
fun elaborateSigexp arg : Interface.t =
- Trace.traceInfo' (info, Sigexp.layout, Layout.ignore)
- (fn (sigexp: Sigexp.t) =>
+ Trace.traceInfo' (info,
+ Layout.tuple2 (Sigexp.layout,
+ Interface.layout),
+ Interface.layout)
+ (fn (sigexp: Sigexp.t, I: Interface.t) =>
case Sigexp.node sigexp of
Sigexp.Spec spec => (* rule 62 *)
- #2 (Maker.makeInterface (m, fn () => elaborateSpec spec))
+ elaborateSpec (spec, I)
| Sigexp.Var x => (* rule 63 *)
- Env.lookupSigid (E, x)
- | Sigexp.Where (sigexp, _) => (* rule 64 *)
- elaborateSigexp sigexp) arg
- and elaborateSpec arg : unit =
- Trace.traceInfo' (info', Ast.Spec.layout, Layout.ignore)
- (fn (spec: Ast.Spec.t) =>
+ Interface.copy (Env.lookupSigid (E, x))
+ | Sigexp.Where (sigexp, wheres) => (* rule 64 *)
+ let
+ val I' = elaborateSigexp (sigexp, I)
+ val _ =
+ Interface.wheres
+ (I',
+ Vector.fromListMap
+ (wheres, fn {tyvars, longtycon, ty} =>
+ (longtycon,
+ TypeStr.def
+ (Scheme.make (elaborateType (ty, E, I)),
+ Kind.Arity (Vector.length tyvars)))))
+ in
+ I'
+ end) arg
+ and elaborateSpec arg : Interface.t =
+ Trace.traceInfo' (info',
+ Layout.tuple2 (Ast.Spec.layout, Layout.ignore),
+ Layout.ignore)
+ (fn (spec: Ast.Spec.t, I: Interface.t) =>
case Spec.node spec of
Spec.Datatype rhs => (* rules 71, 72 *)
(case DatatypeRhs.node rhs of
- DatatypeRhs.DatBind b =>
- let
- val DatBind.T {datatypes, withtypes} =
- DatBind.node b
- val _ =
- Vector.foreach
- (datatypes, fn {tycon, cons, ...} =>
- Maker.addTycon (m, tycon,
- Vector.map (cons, #1)))
- val Ast.TypBind.T l =
- Ast.TypBind.node withtypes
- val _ =
- List.foreach
- (l, fn {tycon, ...} =>
- Maker.addTycon (m, tycon, Vector.new0 ()))
- in ()
- end
+ DatatypeRhs.DatBind b => elaborateDatBind (b, E, I)
| DatatypeRhs.Repl {lhs, rhs} =>
- Maker.addTycon (m, lhs,
- Maker.lookupLongtycon (m, rhs)))
+ let
+ val s = lookupLongtycon (E, I, rhs)
+ in
+ Interface.+
+ (Interface.types (Vector.new1 {name = lhs,
+ typeStr = s}),
+ Interface.cons (TypeStr.cons s))
+ end)
| Spec.Empty => (* rule 76 *)
- ()
+ Interface.empty
| Spec.Eqtype typedescs => (* rule 70 *)
- List.foreach (typedescs, fn {tycon, ...} =>
- Maker.addTycon (m, tycon, Vector.new0 ()))
+ elaborateTypedescs (typedescs, {equality = true})
| Spec.Exception cons => (* rule 73 *)
- List.foreach
- (cons, fn (con, _) => Maker.addExcon (m, con))
+ Interface.excons
+ (Cons.T
+ (Vector.fromListMap
+ (cons, fn (name: TypeStr.Name.t,
+ arg: Ast.Type.t option) =>
+ let
+ val con = Con.newNoname ()
+ val (arg, ty) =
+ case arg of
+ NONE => (NONE, Type.exn)
+ | SOME t =>
+ let
+ val t =
+ Scheme.ty
+ (elaborateScheme (Vector.new0 (),
+ t, E, I))
+ in
+ (SOME t, Type.arrow (t, Type.exn))
+ end
+ in
+ {con = con: TypeStr.Con.t,
+ name= name: TypeStr.Name.t,
+ scheme = Scheme.make (Vector.new0 (), ty)}
+ end)))
| Spec.IncludeSigexp sigexp => (* rule 75 *)
- Maker.includeInterface (m, elaborateSigexp sigexp)
+ elaborateSigexp (sigexp, I)
| Spec.IncludeSigids sigids => (* Appendix A, p.59 *)
- List.foreach
- (sigids, fn sigid =>
- Maker.includeInterface (m, Env.lookupSigid (E, sigid)))
+ List.fold
+ (sigids, Interface.empty, fn (sigid, I) =>
+ Interface.+
+ (I, Interface.copy (Env.lookupSigid (E, sigid))))
| Spec.Seq (s, s') => (* rule 77 *)
- (elaborateSpec s; elaborateSpec s')
- | Spec.Sharing {spec, ...} =>
+ let
+ val I' = elaborateSpec (s, I)
+ val I'' = elaborateSpec (s', Interface.+ (I', I))
+ in
+ Interface.+ (I', I'')
+ end
+ | Spec.Sharing {equations, spec} =>
(* rule 78 and section G.3.3 *)
- elaborateSpec spec
+ let
+ val I' = elaborateSpec (spec, I)
+ fun share eqn =
+ case Equation.node eqn of
+ Equation.Structure ss =>
+ let
+ fun loop ss =
+ case ss of
+ [] => ()
+ | s :: ss =>
+ (List.foreach
+ (ss, fn s' =>
+ Interface.share (I', s, s'))
+ ; loop ss)
+ in
+ loop ss
+ end
+ | Equation.Type cs =>
+ case cs of
+ [] => ()
+ | c :: cs =>
+ List.foreach
+ (cs, fn c' =>
+ Interface.shareType (I', c, c'))
+ val _ = List.foreach (equations, share)
+ in
+ I'
+ end
| Spec.Structure ss => (* rules 74, 84 *)
- List.foreach (ss, fn (strid, sigexp) =>
- Maker.addStrid
- (m, strid, elaborateSigexp sigexp))
+ Interface.strs
+ (Vector.fromListMap
+ (ss, fn (strid, sigexp) =>
+ {interface = elaborateSigexp (sigexp, I),
+ name = strid}))
| Spec.Type typedescs => (* rule 69 *)
- List.foreach (typedescs, fn {tycon, ...} =>
- Maker.addTycon (m, tycon, Vector.new0 ()))
- | Spec.TypeDefs typedefs => (* rule 69 *)
- List.foreach (typedefs, fn {tycon, ...} =>
- Maker.addTycon (m, tycon, Vector.new0 ()))
+ elaborateTypedescs (typedescs, {equality = false})
+ | Spec.TypeDefs typBind =>
+ (* Abbreviation on page 59,
+ * combined with rules 77 and 80.
+ *)
+ let
+ val TypBind.T ds = TypBind.node typBind
+ in
+ #2
+ (List.fold
+ (ds, (I, Interface.empty),
+ fn ({def, tycon, tyvars}, (I, I')) =>
+ let
+ val I'' =
+ Interface.types
+ (Vector.new1
+ {name = tycon,
+ typeStr = (TypeStr.def
+ (elaborateScheme (tyvars, def, E, I),
+ Kind.Arity (Vector.length tyvars)))})
+ in
+ (Interface.+ (I, I''), Interface.+ (I', I''))
+ end))
+ end
| Spec.Val xts => (* rules 68, 79 *)
- List.foreach (xts, fn (x, _) => Maker.addVar (m, x))
+ Interface.vals
+ (Vector.fromListMap
+ (xts, fn (x, t) =>
+ {name = Ast.Vid.fromVar x,
+ scheme = Scheme.make (elaborateType (t, E, I)),
+ status = Status.Var}))
) arg
- in elaborateSigexp sigexp
+ in
+ elaborateSigexp (sigexp, Interface.empty)
end
val elaborateSigexp =
1.5 +4 -0 mlton/mlton/elaborate/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm 9 Oct 2003 18:17:33 -0000 1.4
+++ sources.cm 7 Nov 2003 00:21:28 -0000 1.5
@@ -31,9 +31,13 @@
elaborate-sigexp.sig
elaborate.fun
elaborate.sig
+interface.fun
+interface.sig
precedence-parse.fun
precedence-parse.sig
scope.fun
scope.sig
type-env.fun
type-env.sig
+type-str.fun
+type-str.sig
1.10 +41 -1 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- type-env.fun 16 Oct 2003 22:37:12 -0000 1.9
+++ type-env.fun 7 Nov 2003 00:21:28 -0000 1.10
@@ -595,6 +595,21 @@
Con x => SOME x
| _ => NONE
+ fun deEta (t: t, tyvars: Tyvar.t vector): Tycon.t option =
+ case deConOpt t of
+ SOME (c, ts) =>
+ if Vector.length ts = Vector.length tyvars
+ andalso Vector.foralli (ts, fn (i, t) =>
+ case toType t of
+ Var a =>
+ Tyvar.equals
+ (a, Vector.sub (tyvars, i))
+ | _ => false)
+ then SOME c
+ else NONE
+ | _ => NONE
+
+
fun newTy (ty: ty, eq: Equality.t): t =
T (Set.singleton {equality = eq,
plist = PropertyList.new (),
@@ -1103,11 +1118,12 @@
fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
record: t * (Field.t * 'a) vector -> 'a,
+ replaceCharWithWord8: bool,
var: t * Tyvar.t -> 'a} =
let
val con =
fn (t, c, ts) =>
- if Tycon.equals (c, Tycon.char)
+ if replaceCharWithWord8 andalso Tycon.equals (c, Tycon.char)
then con (word8, Tycon.word WordSize.W8, Vector.new0 ())
else con (t, c, ts)
val unit = con (unit, Tycon.tuple, Vector.new0 ())
@@ -1195,6 +1211,8 @@
fn General {ty, ...} => ty
| Type ty => ty
+ fun dest s = (bound s, ty s)
+
fun make {canGeneralize, tyvars, ty} =
if 0 = Vector.length tyvars
then Type ty
@@ -1525,6 +1543,7 @@
in
simpleHom {con = con,
record = fn (t, fs) => tuple (t, Vector.map (fs, #2)),
+ replaceCharWithWord8 = true,
var = var}
end
@@ -1540,6 +1559,7 @@
record = fn (t, fs) => (t,
SOME (Vector.map (fs, fn (f, (t, _)) =>
(f, t)))),
+ replaceCharWithWord8 = true,
var = fn (t, _) => (t, NONE)}
val res =
case #2 (hom t) of
@@ -1571,5 +1591,25 @@
deTupleOpt
val deTuple = valOf o deTupleOpt
+
+ fun hom (t, {con, record, var}) =
+ let
+ val {hom, destroy} =
+ simpleHom {con = fn (_, c, v) => con (c, v),
+ record = fn (_, fs) => record (Srecord.fromVector fs),
+ replaceCharWithWord8 = false,
+ var = fn (_, a) => var a}
+ val res = hom t
+ val _ = destroy ()
+ in
+ res
+ end
+
+ val unify =
+ fn (t1: t, t2: t,
+ f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t) =>
+ case unify (t1, t2) of
+ NotUnifiable z => Control.error (f z)
+ | Unified => ()
end
end
1.5 +8 -4 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- type-env.sig 16 Oct 2003 22:37:12 -0000 1.4
+++ type-env.sig 7 Nov 2003 00:21:28 -0000 1.5
@@ -23,8 +23,12 @@
(* can two types be unified? not side-effecting. *)
val canUnify: t * t -> bool
val char: t
+ val deEta: t * Tyvar.t vector -> Tycon.t option
val deRecord: t -> (Record.Field.t * t) vector
val flexRecord: t SortedRecord.t -> t * (unit -> bool)
+ val hom: t * {con: Tycon.t * 'a vector -> 'a,
+ record: 'a SortedRecord.t -> 'a,
+ var: Tyvar.t -> 'a} -> 'a
val makeHom: {con: Tycon.t * 'a vector -> 'a,
var: Tyvar.t -> 'a} -> {destroy: unit -> unit,
hom: t -> 'a}
@@ -36,10 +40,8 @@
val string: t
val toString: t -> string
(* make two types identical (recursively). side-effecting. *)
- datatype unifyResult =
- NotUnifiable of Layout.t * Layout.t
- | Unified
- val unify: t * t -> unifyResult
+ val unify: t * t * (Layout.t * Layout.t
+ -> Region.t * Layout.t * Layout.t) -> unit
val unresolvedInt: unit -> t
val unresolvedReal: unit -> t
val unresolvedWord: unit -> t
@@ -55,6 +57,8 @@
val admitsEquality: t -> bool
val apply: t * Type.t vector -> Type.t
+ val bound: t -> Tyvar.t vector
+ val dest: t -> Tyvar.t vector * Type.t
val fromType: Type.t -> t
val haveFrees: t vector -> bool vector
val instantiate: t -> {args: unit -> Type.t vector,
1.1 mlton/mlton/elaborate/interface.fun
Index: interface.fun
===================================================================
(* Copyright (C) 1999-2002 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.
*)
functor Interface (S: INTERFACE_STRUCTS): INTERFACE =
struct
open S
local
open Ast
in
structure Longstrid = Longstrid
structure Longtycon = Longtycon
structure Record = SortedRecord
structure Strid = Strid
structure Tyvar = Tyvar
end
structure Field = Record.Field
structure EtypeStr = EnvTypeStr
local
open EtypeStr
in
structure Con = Con
structure Econs = Cons
structure Kind = Kind
structure Escheme = Scheme
structure Etycon = Tycon
structure Etype = Type
end
structure AdmitsEquality = Etycon.AdmitsEquality
structure Set = DisjointSet
structure ShapeId = UniqueId ()
structure Status:
sig
datatype t = Con | Exn | Var
val layout: t -> Layout.t
val toString: t -> string
end =
struct
datatype t = Con | Exn | Var
val toString =
fn Con => "Con"
| Exn => "Exn"
| Var => "Var"
val layout = Layout.str o toString
end
(* only needed for debugging *)
structure TyconId = IntUniqueId()
structure FlexibleTycon =
struct
structure TypeFcn =
struct
datatype t =
Forced of EtypeStr.t
| Fun
| Tycon
fun layout f =
let
open Layout
in
case f of
Forced f => paren (seq [str "forced ", EtypeStr.layout f])
| Fun => str "<flexible def>"
| Tycon => str "<flexible tycon>"
end
fun layoutApp (f: t, v: (Layout.t * {isChar: bool,
needsParen: bool}) vector) =
let
open Layout
in
(seq [paren (layout f), tuple (Vector.toListMap (v, #1))],
{isChar = false, needsParen = true})
end
val toEnv: t -> EtypeStr.t =
fn Forced f => f
| _ => Error.bug "impossible force of FlexibleTycon"
end
datatype t = T of {admitsEquality: AdmitsEquality.t ref,
copy: copy,
hasCons: bool,
id: TyconId.t,
typeFcn: TypeFcn.t} Set.t
withtype copy = t option ref
val equals = fn (T s, T s') => Set.equals (s, s')
fun dest (T s) = Set.value s
fun setValue (T s, r) = Set.setValue (s, r)
fun admitsEquality t = #admitsEquality (dest t)
fun isFlexible (T s) =
case #typeFcn (Set.value s) of
TypeFcn.Tycon => true
| _ => false
fun layout (T s) =
let
open Layout
val {hasCons, id, typeFcn, ...} = Set.value s
in
record [("hasCons", Bool.layout hasCons),
("id", TyconId.layout id),
("typeFcn", TypeFcn.layout typeFcn)]
end
fun setTypeStr (T s, e: EtypeStr.t): unit =
let
val {admitsEquality, copy, id, hasCons, ...} = Set.value s
in
Set.setValue (s, {admitsEquality = admitsEquality,
copy = copy,
hasCons = hasCons,
id = id,
typeFcn = TypeFcn.Forced e})
end
fun new {hasCons: bool, typeFcn: TypeFcn.t}: t =
T (Set.singleton {admitsEquality = ref AdmitsEquality.Sometimes,
copy = ref NONE,
hasCons = hasCons,
id = TyconId.new (),
typeFcn = typeFcn})
fun make () = new {hasCons = false, typeFcn = TypeFcn.Tycon}
val bogus = make ()
fun toTypeFcn (T s) = #typeFcn (Set.value s)
fun layoutApp (t, v) =
TypeFcn.layoutApp (toTypeFcn t, v)
val copies: copy list ref = ref []
fun copy (T s): t =
let
val {copy, typeFcn, hasCons, ...} = Set.value s
in
case !copy of
NONE =>
let val c = new {hasCons = hasCons,
typeFcn = typeFcn}
in List.push (copies, copy)
; copy := SOME c
; c
end
| SOME c => c
end
fun shareOK (T s, T s') =
let
val {admitsEquality = a, hasCons = h, id, typeFcn = f, ...} =
Set.value s
val {admitsEquality = a', hasCons = h', typeFcn = f', ...} =
Set.value s'
val _ = Set.union (s, s')
val _ =
Set.setValue
(s, {admitsEquality = ref (AdmitsEquality.or (!a, !a')),
copy = ref NONE,
id = id,
hasCons = h orelse h',
typeFcn = TypeFcn.Tycon})
in
()
end
fun share (f, z, f', z'): unit =
let
fun error (reg, lay) =
let
open Layout
in
Control.error
(reg,
seq [str "type ", lay (),
str " is a definition and cannot be shared"],
empty)
end
in
case (toTypeFcn f, toTypeFcn f') of
(TypeFcn.Fun, _) => error z
| (_, TypeFcn.Fun) => error z'
| (TypeFcn.Tycon, TypeFcn.Tycon) => shareOK (f, f')
| _ => Error.bug "type sharing on Forced typeFcn"
end
fun toEnv (T s): EtypeStr.t =
TypeFcn.toEnv (#typeFcn (Set.value s))
end
structure Tycon =
struct
structure AdmitsEquality = AdmitsEquality
datatype t =
Flexible of FlexibleTycon.t
| Rigid of Etycon.t * Kind.t
val layout =
fn Flexible c => FlexibleTycon.layout c
| Rigid (c, _) => Etycon.layout c
val equals =
fn (Flexible f, Flexible f') => FlexibleTycon.equals (f, f')
| (Rigid (c, _), Rigid (c', _)) => Etycon.equals (c, c')
| _ => false
val exn = Rigid (Etycon.exn, Kind.Arity 0)
fun admitsEquality (t: t): AdmitsEquality.t ref =
case t of
Flexible f => FlexibleTycon.admitsEquality f
| Rigid (e, _) => Etycon.admitsEquality e
val fromEnv: Etycon.t * Kind.t -> t = Rigid
fun layoutApp (t: t, v) =
case t of
Flexible f => FlexibleTycon.layoutApp (f, v)
| Rigid (c, _) => Etycon.layoutApp (c, v)
val make = Flexible o FlexibleTycon.make
fun copy (t: t): t =
case t of
Flexible c => Flexible(FlexibleTycon.copy c)
| Rigid _ => t
fun toEnv (t: t): EtypeStr.t =
case t of
Flexible c => FlexibleTycon.toEnv c
| Rigid (c, k) => EtypeStr.tycon (c, k)
val arrow = fromEnv (Etycon.arrow, Kind.Arity 2)
val exn = fromEnv (Etycon.exn, Kind.Arity 0)
fun toFlexible (c: t): FlexibleTycon.t option =
case c of
Flexible c => SOME c
| Rigid _ => NONE
end
structure Type =
struct
datatype t =
Con of Tycon.t * t vector
| Record of t Record.t
| Var of Tyvar.t
val bogus = Con (Tycon.exn, Vector.new0 ())
val con = Con
val record = Record
val var = Var
val exn = Con (Tycon.exn, Vector.new0 ())
fun hom (t, {con, record, var}) =
let
val rec loop =
fn Con (c, ts) => con (c, Vector.map (ts, loop))
| Record r => record (Record.map (r, loop))
| Var a => var a
in
loop t
end
local
open Layout
fun simple l = (l, {isChar = false, needsParen = false})
fun loop t =
case t of
Con (c, ts) => Tycon.layoutApp (c, Vector.map (ts, loop))
| Record r =>
simple
(seq
[str "{",
mayAlign
(separateRight
(Vector.toListMap
(QuickSort.sortVector
(Record.toVector r, fn ((f, _), (f', _)) =>
Field.<= (f, f')),
fn (f, t) =>
seq [Field.layout f, str ": ", #1 (loop t)]),
",")),
str "}"])
| Var a => simple (Tyvar.layout a)
in
val layout = #1 o loop
end
fun toEnv t =
hom (t, {con = fn (c, ts) => EtypeStr.apply (Tycon.toEnv c, ts),
record = Etype.record,
var = Etype.var})
fun fromEnv (t: Etype.t): t =
let
fun con (c, ts) =
Con (Tycon.fromEnv (c, Kind.Arity (Vector.length ts)), ts)
in
Etype.hom (t, {con = con,
record = Record,
var = Var})
end
fun copy (t: t): t =
hom (t, {con = fn (c, ts) => Con (Tycon.copy c, ts),
record = Record,
var = Var})
fun arrow (t1, t2) = Con (Tycon.arrow, Vector.new2 (t1, t2))
fun substitute (t: t, sub: (Tyvar.t * t) vector): t =
let
fun var a =
case Vector.peek (sub, fn (a', _) => Tyvar.equals (a, a')) of
NONE => Error.bug "substitute"
| SOME (_, t) => t
in
hom (t, {con = Con,
record = Record,
var = var})
end
fun deEta (t: t, tyvars: Tyvar.t vector): Tycon.t option =
case t of
Con (c, ts) =>
if Vector.length ts = Vector.length tyvars
andalso Vector.foralli (ts, fn (i, t) =>
case t of
Var a =>
Tyvar.equals
(a, Vector.sub (tyvars, i))
| _ => false)
then SOME c
else NONE
| _ => NONE
end
structure Scheme = GenericScheme (structure Type = Type
structure Tyvar = Tyvar)
structure Scheme =
struct
open Scheme
fun copy (T {tyvars, ty}): t =
T {ty = Type.copy ty, tyvars = tyvars}
fun dest (T {ty, tyvars}) = (tyvars, ty)
fun make (tyvars, ty) = T {ty = ty, tyvars = tyvars}
fun bogus () = T {ty = Type.bogus, tyvars = Vector.new0 ()}
fun toEnv (Scheme.T {ty, tyvars}) =
Escheme.make (tyvars, Type.toEnv ty)
fun admitsEquality (s: t): bool =
let
fun con (c, bs) =
let
datatype z = datatype AdmitsEquality.t
in
case ! (Tycon.admitsEquality c) of
Always => true
| Never => false
| Sometimes => Vector.forall (bs, fn b => b)
end
in
Type.hom (ty s, {con = con,
record = fn r => Record.forall (r, fn b => b),
var = fn _ => true})
end
fun fromEnv (s: Escheme.t): t =
let
val (tyvars, ty) = Escheme.dest s
in
make (tyvars, Type.fromEnv ty)
end
end
structure TypeStr = TypeStr (structure Con = Con
structure Kind = Kind
structure Name = Ast.Con
structure Record = Record
structure Scheme = Scheme
structure Tycon = Tycon
structure Type = Type
structure Tyvar = Tyvar)
structure Cons =
struct
open TypeStr.Cons
fun copy (T v): t =
T (Vector.map (v, fn {con, name, scheme} =>
{con = con,
name = name,
scheme = Scheme.copy scheme}))
fun toEnv (T v): Econs.t =
Econs.T (Vector.map (v, fn {con, name, scheme} =>
{con = con,
name = name,
scheme = Scheme.toEnv scheme}))
fun fromEnv (Econs.T v): t =
T (Vector.map (v, fn {con, name, scheme} =>
{con = con,
name = name,
scheme = Scheme.fromEnv scheme}))
end
structure TypeStr =
struct
structure Cons' = Cons
structure Scheme' = Scheme
structure Tycon' = Tycon
structure Type' = Type
open TypeStr
structure Cons = Cons'
structure Scheme = Scheme'
structure Tycon = Tycon'
structure Type = Type'
fun toFlexible (s: t): FlexibleTycon.t option =
case node s of
Datatype {tycon, ...} => Tycon.toFlexible tycon
| Tycon c => Tycon.toFlexible c
| _ => NONE
fun copy (s: t): t =
let
val kind = kind s
in
case node s of
Datatype {cons, tycon} => data (Tycon.copy tycon,
kind,
Cons.copy cons)
| Scheme s => def (Scheme.copy s, kind)
| Tycon c => tycon (Tycon.copy c, kind)
end
fun toEnv (s: t): EtypeStr.t =
let
val k = kind s
in
case node s of
Datatype {cons, tycon} =>
let
val tycon: Etycon.t =
case tycon of
Tycon.Flexible c =>
let
val typeStr = FlexibleTycon.toEnv c
in
case EtypeStr.node typeStr of
EtypeStr.Datatype {tycon, ...} => tycon
| EtypeStr.Tycon c => c
| _ =>
let
open Layout
in
Error.bug
(toString
(seq [str "datatype ",
layout s,
str " realized with scheme ",
EtypeStr.layout typeStr]))
end
end
| Tycon.Rigid (c, _) => c
in
EtypeStr.data (tycon, k, Cons.toEnv cons)
end
| Scheme s => EtypeStr.def (Scheme.toEnv s, k)
| Tycon c => EtypeStr.abs (Tycon.toEnv c)
end
val toEnv = Trace.trace ("TypeStr.toEnv", layout, EtypeStr.layout) toEnv
fun fromEnv (s: EtypeStr.t) =
let
val kind = EtypeStr.kind s
in
case EtypeStr.node s of
EtypeStr.Datatype {cons, tycon} =>
data (Tycon.fromEnv (tycon, kind),
kind,
Cons.fromEnv cons)
| EtypeStr.Scheme s => def (Scheme.fromEnv s, kind)
| EtypeStr.Tycon c =>
tycon (Tycon.fromEnv (c, kind), kind)
end
val fromEnv =
Trace.trace ("TypeStr.fromEnv", EtypeStr.layout, layout) fromEnv
fun share (s: t, z, s': t, z'): unit =
let
fun getFlex (s: t, (reg, lay),
continue: FlexibleTycon.t -> unit): unit =
let
fun error what =
let
open Layout
in
Control.error
(reg,
seq [str "type ", lay (),
str (concat [" is ", what,
" and cannot be shared"])],
empty)
end
fun get c =
case c of
Tycon.Flexible f => continue f
| Tycon.Rigid _ => error "a toplevel type"
in
case node s of
Datatype {tycon, ...} => get tycon
| Scheme _ => error "a definition"
| Tycon c => get c
end
val k = kind s
val k' = kind s'
in
if not (Kind.equals (k, k'))
then
let
val (reg, lay) = z
val (_, lay') = z'
open Layout
in
Control.error
(reg,
seq [str "type ", lay (),
str " has arity ", Kind.layout k,
str " and type ", lay' (),
str " has arity ", Kind.layout k',
str " so cannot be shared"],
empty)
end
else
getFlex (s, z, fn c =>
getFlex (s', z', fn c' =>
FlexibleTycon.share (c, z, c', z')))
end
end
(*---------------------------------------------------*)
(* Main Datatype *)
(*---------------------------------------------------*)
(* Invariant: only ever union two envs if they have the same shape. *)
(* The shape of interface is the set of longtycons that are accessible in it. *)
datatype t = T of {copy: copy,
elements: element list,
shapeId: ShapeId.t,
wheres: (FlexibleTycon.t * TypeStr.t) list ref} Set.t
and element =
Str of {interface: t,
name: Ast.Strid.t}
| Type of {name: Ast.Tycon.t,
typeStr: TypeStr.t}
| Val of {name: Ast.Vid.t,
scheme: Scheme.t,
status: Status.t}
withtype copy = t option ref
type interface = t
fun equals (T s, T s') = Set.equals (s, s')
local
open Layout
in
fun layout(T s) =
let
val {elements, wheres, ...} = Set.value s
in
record[("elements", list (List.map (elements, layoutElement))),
("wheres", list (List.map (!wheres, fn (c, f) =>
tuple [FlexibleTycon.layout c,
TypeStr.layout f])))]
end
and layoutElement (e: element) =
let
val (lhs, rhs) =
case e of
Val{name, scheme, status} =>
(Ast.Vid.layout name,
tuple[Status.layout status,
Scheme.layout scheme])
| Type{name, typeStr} =>
(Ast.Tycon.layout name,
TypeStr.layout typeStr)
| Str{name, interface} =>
(Ast.Strid.layout name, layout interface)
in seq [lhs, str " -> ", rhs]
end
end
fun explicit elements: t =
T (Set.singleton {copy = ref NONE,
elements = elements,
shapeId = ShapeId.new (),
wheres = ref []})
val empty = explicit []
val bogus = empty
fun vals v = explicit (Vector.toListMap (v, Val))
fun strs v = explicit (Vector.toListMap (v, Str))
fun types v = explicit (Vector.toListMap (v, Type))
local
fun make status (Cons.T cs) =
explicit (Vector.toListMap (cs, fn {name, scheme, ...} =>
Val {name = Ast.Vid.fromCon name,
scheme = scheme,
status = status}))
in
val cons = make Status.Con
val excons = make Status.Exn
end
fun elements (T s): element list = #elements (Set.value s)
fun shapeId (T s) = #shapeId (Set.value s)
fun extendTycon (I, tycon, typeStr) =
explicit (elements I @ [Type {name = tycon, typeStr = typeStr}])
val op + = fn (I, I') => explicit (elements I @ elements I')
fun peekTyconElements (elements: element list, tycon): TypeStr.t option =
case List.peek (elements,
fn Type {name, ...} => Ast.Tycon.equals(tycon,name)
| _ => false) of
NONE => NONE
| SOME (Type {typeStr, ...}) => SOME typeStr
| _ => Error.bug "peekTyconElements"
fun peekStridElements (elements, strid): t option =
case List.peek (elements,
fn Str {name, ...} => Strid.equals(strid,name)
| _ => false) of
NONE => NONE
| SOME (Str {interface, ...}) => SOME interface
| _ => Error.bug "peekStridElements"
fun peekStrid (I: t, strid: Ast.Strid.t): t option =
peekStridElements (elements I, strid)
datatype 'a peekResult =
Found of t
| UndefinedStructure of Strid.t list
fun peekStrids (I: t, strids: Ast.Strid.t list): t peekResult =
let
fun loop (I, strids, ac) =
case strids of
[] => Found I
| strid :: strids =>
case peekStrid (I, strid) of
NONE => UndefinedStructure (rev (strid :: ac))
| SOME I => loop (I, strids, strid :: ac)
in
loop (I, strids, [])
end
fun unbound (r: Region.t, className, x: Layout.t): unit =
Control.error
(r,
let open Layout
in seq [str "undefined ", str className, str " ", x]
end,
Layout.empty)
fun layoutStrids (ss: Strid.t list): Layout.t =
Layout.str (concat (List.separate (List.map (ss, Strid.toString), ".")))
fun lookupLongstrid (I: t, s: Longstrid.t): t =
let
val (strids, strid) = Longstrid.split s
in
case peekStrids (I, strids @ [strid]) of
Found I => I
| UndefinedStructure ss =>
(unbound (Longstrid.region s, "structure", layoutStrids ss)
; bogus)
end
structure PeekResult =
struct
datatype 'a t =
Found of 'a
| UndefinedStructure of Strid.t list
| Undefined
fun layout lay =
fn Found z => lay z
| UndefinedStructure ss => layoutStrids ss
| Undefined => Layout.str "Undefined"
val toOption: 'a t -> 'a option =
fn Found z => SOME z
| _ => NONE
end
fun peekLongtycon (I: t, c: Longtycon.t): TypeStr.t PeekResult.t =
let
val (strids, c) = Longtycon.split c
in
case peekStrids (I, strids) of
Found I =>
(case peekTyconElements (elements I, c) of
NONE => PeekResult.Undefined
| SOME s => PeekResult.Found s)
| UndefinedStructure ss => PeekResult.UndefinedStructure ss
end
fun lookupLongtycon (I: t, c: Longtycon.t, continue: TypeStr.t -> unit): unit =
let
datatype z = datatype PeekResult.t
in
case peekLongtycon (I, c) of
Found s => continue s
| UndefinedStructure ss =>
unbound (Longtycon.region c, "structure", layoutStrids ss)
| Undefined =>
unbound (Longtycon.region c, "type", Longtycon.layout c)
end
val peekLongtycon =
fn z =>
let
datatype z = datatype PeekResult.t
in
case peekLongtycon z of
Found s => SOME s
| _ => NONE
end
fun shareType (I: t, c: Longtycon.t, c': Longtycon.t) =
lookupLongtycon
(I, c, fn s =>
lookupLongtycon
(I, c', fn s' =>
TypeStr.share (s, (Longtycon.region c, fn () => Longtycon.layout c),
s', (Longtycon.region c', fn () => Longtycon.layout c'))))
fun sameShape (m, m') = ShapeId.equals (shapeId m, shapeId m')
fun share (I as T s, reg: Region.t, I' as T s', reg', strids): unit =
if Set.equals (s, s')
then ()
else
if sameShape (I, I')
then
let
fun loop (T s, T s', strids): unit =
if Set.equals (s, s')
then ()
else
let
val {elements = es, ...} = Set.value s
val {elements = es', ...} = Set.value s'
val _ = Set.union (s, s')
val _ =
List.foreach2
(es, es', fn (e, e') =>
case (e, e') of
(Str {interface = I, name, ...},
Str {interface = I', ...}) =>
loop (I, I', name :: strids)
| (Type {typeStr = s, name, ...},
Type {typeStr = s', ...}) =>
let
fun lay () =
Ast.Longtycon.layout
(Ast.Longtycon.long (rev strids, name))
in
TypeStr.share (s, (reg, lay),
s', (reg', lay))
end
| _ => ())
in
()
end
in
loop (I, I', strids)
end
else (* different shapes -- need to share pointwise *)
let
val es = elements I
val es' = elements I'
in
List.foreach
(es, fn e =>
case e of
Str {name, interface = I} =>
(case peekStridElements (es', name) of
NONE => ()
| SOME I' => share (I, reg, I', reg', name :: strids))
| Type {name, typeStr = s} =>
(case peekTyconElements (es',name) of
NONE => ()
| SOME s' =>
let
fun lay () =
Ast.Longtycon.layout
(Ast.Longtycon.long (rev strids, name))
in
TypeStr.share (s, (reg, lay), s', (reg', lay))
end)
| _ => ())
end
val share =
fn (m, s: Longstrid.t, s': Longstrid.t) =>
share (lookupLongstrid (m, s),
Longstrid.region s,
lookupLongstrid (m, s'),
Longstrid.region s',
[])
structure TypeFcn = FlexibleTycon.TypeFcn
fun wheres (I as T s, v: (Longtycon.t * TypeStr.t) vector): unit =
let
val {wheres, ...} = Set.value s
in
Vector.foreach
(v, fn (c, s: TypeStr.t) =>
let
val reg = Longtycon.region c
fun noRedefine () =
let
open Layout
in
Control.error (reg,
seq [str "type ",
Longtycon.layout c,
str " cannot be redefined"],
empty)
end
in
lookupLongtycon
(I, c, fn s' =>
case TypeStr.toFlexible s' of
NONE => noRedefine ()
| SOME flex =>
let
val {admitsEquality, copy, hasCons, id, typeFcn} =
FlexibleTycon.dest flex
in
if hasCons andalso (case TypeStr.node s of
TypeStr.Scheme _ => true
| _ => false)
then
let
open Layout
in
Control.error
(reg,
seq [str "type ",
Longtycon.layout c,
str " is a datatype and cannot be defined as complex type"],
empty)
end
else
let
datatype z = datatype TypeFcn.t
in
case typeFcn of
Forced _ =>
Error.bug "where type on forced flexible tycon"
| Fun => noRedefine ()
| Tycon =>
let
fun doWhere () =
(List.push (wheres, (flex, s))
;
FlexibleTycon.setValue
(flex, {admitsEquality = admitsEquality,
copy = copy,
hasCons = hasCons,
id = id,
typeFcn = typeFcn}))
fun doTycon c =
case c of
Tycon.Flexible flex' =>
FlexibleTycon.shareOK (flex, flex')
| Tycon.Rigid (c, _) => doWhere ()
in
case TypeStr.node s of
TypeStr.Datatype {tycon, ...} =>
doTycon tycon
| TypeStr.Scheme _ => doWhere ()
| TypeStr.Tycon c => doTycon c
end
end
end)
end)
end
structure Element =
struct
type interface = t
datatype t =
Str of {name: Ast.Strid.t,
interface: interface}
| Type of {name: Ast.Tycon.t,
typeStr: EtypeStr.t}
| Val of {name: Ast.Vid.t,
scheme: Escheme.t,
status: Status.t}
end
fun copyAndRealize (I: t, getTypeFcnOpt): t =
let
(* Keep track of all nodes that have forward pointers to copies, so
* that we can gc them when done.
*)
val copies: copy list ref = ref []
fun loop (T s, strids: Ast.Strid.t list): t =
let
val {copy, shapeId, elements, wheres, ...} = Set.value s
in
case !copy of
NONE =>
let
val wheres =
List.map
(!wheres, fn (c, s) =>
let
val c = FlexibleTycon.copy c
val s = TypeStr.copy s
val _ =
if isSome getTypeFcnOpt
then
FlexibleTycon.setTypeStr
(c, TypeStr.toEnv s)
else ()
in
(c, s)
end)
val elements =
List.map
(elements, fn e =>
case e of
Str {name, interface} =>
Str {interface = loop (interface,
strids @ [name]),
name = name}
| Type {name, typeStr} =>
let
val typeStr = TypeStr.copy typeStr
val _ =
case (TypeStr.toTyconOpt typeStr,
getTypeFcnOpt) of
(SOME (Tycon.Flexible c), SOME f) =>
let
fun get () =
f
(Longtycon.long (strids, name),
TypeStr.kind typeStr)
fun doit (s: EtypeStr.t): unit =
FlexibleTycon.setTypeStr (c, s)
in
case FlexibleTycon.toTypeFcn c of
TypeFcn.Fun => ()
| TypeFcn.Tycon => doit (get ())
| TypeFcn.Forced s =>
let
val s' = get ()
in
case (EtypeStr.node s,
EtypeStr.node s') of
(EtypeStr.Tycon c,
EtypeStr.Datatype
{tycon = c', ...}) =>
if Etycon.equals (c, c')
then doit s'
else ()
| _ => ()
end
end
| _ => ()
in
Type {name = name,
typeStr = typeStr}
end
| Val {name, scheme, status} =>
Val {name = name,
scheme = Scheme.copy scheme,
status = status})
val I = T (Set.singleton {copy = ref NONE,
shapeId = shapeId,
elements = elements,
wheres = ref wheres})
val _ = List.push (copies, copy)
val _ = copy := SOME I
in
I
end
| SOME I => I
end
val I = loop (I, [])
fun clear copies =
(List.foreach (!copies, fn copy => copy := NONE)
; copies := [])
val _ = clear copies
val _ = clear FlexibleTycon.copies
in
I
end
fun copy I = copyAndRealize (I, NONE)
fun realize (I, f) = copyAndRealize (I, SOME f)
val realize = Trace.trace2 ("realize", layout, Layout.ignore, layout) realize
fun 'a fold (T s, b: 'a, f: Element.t * 'a -> 'a): 'a =
let
val {elements, ...} = Set.value s
in
List.fold
(elements, b, fn (elt, b) =>
let
val elt =
case elt of
Str r => Element.Str r
| Type {name, typeStr} =>
Element.Type {name = name,
typeStr = TypeStr.toEnv typeStr}
| Val {name, scheme, status} =>
Element.Val {name = name,
scheme = Scheme.toEnv scheme,
status = status}
in
f (elt, b)
end)
end
fun foreach (s, f) = fold (s, (), f o #1)
end
1.1 mlton/mlton/elaborate/interface.sig
Index: interface.sig
===================================================================
(* Copyright (C) 1999-2002 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.
*)
type int = Int.t
signature INTERFACE_STRUCTS =
sig
structure Ast: AST
structure EnvTypeStr: TYPE_STR
sharing Ast.Con = EnvTypeStr.Name
sharing Ast.SortedRecord = EnvTypeStr.Record
sharing Ast.Tyvar = EnvTypeStr.Tyvar
end
signature INTERFACE =
sig
include INTERFACE_STRUCTS
structure ShapeId: UNIQUE_ID
structure Tycon:
sig
type t
end
structure Tyvar:
sig
type t
end
structure Type:
sig
type t
val deEta: t * Tyvar.t vector -> Tycon.t option
end
structure Scheme:
sig
type t
end
structure Status:
sig
datatype t = Con | Exn | Var
val layout: t -> Layout.t
val toString: t -> string
end
structure Con:
sig
type t
end
sharing Con = EnvTypeStr.Con
structure Cons:
sig
datatype t = T of {con: Con.t,
name: Ast.Con.t,
scheme: Scheme.t} vector
val empty: t
val layout: t -> Layout.t
end
structure TypeStr:
sig
include TYPE_STR
val fromEnv: EnvTypeStr.t -> t
end
sharing TypeStr.Con = Con
sharing TypeStr.Kind = EnvTypeStr.Kind
sharing TypeStr.Name = EnvTypeStr.Name
sharing TypeStr.Record = EnvTypeStr.Record
sharing TypeStr.Scheme = Scheme
sharing TypeStr.Tycon = Tycon
sharing TypeStr.Type = Type
sharing TypeStr.Tyvar = EnvTypeStr.Tyvar = Tyvar
structure Element:
sig
type interface
datatype t =
Str of {name: Ast.Strid.t,
interface: interface}
| Type of {name: Ast.Tycon.t,
typeStr: EnvTypeStr.t}
| Val of {name: Ast.Vid.t,
scheme: EnvTypeStr.Scheme.t,
status: Status.t}
end
type t
sharing type t = Element.interface
val + : t * t -> t
val bogus: t
val cons: TypeStr.Cons.t -> t
val copy: t -> t (* copy renames all flexible tycons. *)
val empty: t
val equals: t * t -> bool
val excons: TypeStr.Cons.t -> t
val extendTycon: t * Ast.Tycon.t * TypeStr.t -> t
val fold: t * 'a * (Element.t * 'a -> 'a) -> 'a
val layout: t -> Layout.t
val peekLongtycon: t * Ast.Longtycon.t -> TypeStr.t option
(* realize makes a copy, and instantiate longtycons *)
val realize: t * (Ast.Longtycon.t * TypeStr.Kind.t -> EnvTypeStr.t) -> t
val shapeId: t -> ShapeId.t
val share: t * Ast.Longstrid.t * Ast.Longstrid.t -> unit
val shareType: t * Ast.Longtycon.t * Ast.Longtycon.t -> unit
val strs: {name: Ast.Strid.t, interface: t} vector -> t
val types: {name: Ast.Tycon.t, typeStr: TypeStr.t} vector -> t
val vals: {name: Ast.Vid.t,
scheme: Scheme.t,
status: Status.t} vector -> t
val wheres: t * (Ast.Longtycon.t * TypeStr.t) vector -> unit
end
1.1 mlton/mlton/elaborate/type-str.fun
Index: type-str.fun
===================================================================
(* Copyright (C) 1999-2002 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.
*)
functor TypeStr (S: TYPE_STR_STRUCTS): TYPE_STR =
struct
open S
structure Cons =
struct
datatype t = T of {con: Con.t,
name: Name.t,
scheme: Scheme.t} vector
val empty = T (Vector.new0 ())
fun layout (T v) =
Vector.layout (fn {con, name, scheme} =>
Layout.tuple [Name.layout name,
Con.layout con,
Layout.str ": ",
Scheme.layout scheme])
v
end
datatype node =
Datatype of {cons: Cons.t,
tycon: Tycon.t}
| Scheme of Scheme.t
| Tycon of Tycon.t
datatype t = T of {kind: Kind.t,
node: node}
local
fun make f (T r) = f r
in
val kind = make #kind
val node = make #node
end
fun layout t =
let
open Layout
in
case node t of
Datatype {tycon, cons} =>
seq [str "Datatype ",
record [("tycon", Tycon.layout tycon),
("cons", Cons.layout cons)]]
| Scheme s => Scheme.layout s
| Tycon t => seq [str "Tycon ", Tycon.layout t]
end
fun bogus (k: Kind.t): t =
T {kind = k,
node = Scheme (Scheme.bogus ())}
fun abs t =
case node t of
Datatype {tycon, ...} => T {kind = kind t,
node = Tycon tycon}
| _ => t
fun apply (t: t, tys: Type.t vector): Type.t =
case node t of
Datatype {tycon, ...} => Type.con (tycon, tys)
| Scheme s => Scheme.apply (s, tys)
| Tycon t => Type.con (t, tys)
fun cons t =
case node t of
Datatype {cons, ...} => cons
| _ => Cons.empty
fun data (tycon, kind, cons) =
T {kind = kind,
node = Datatype {tycon = tycon, cons = cons}}
fun def (s: Scheme.t, k: Kind.t) =
let
val (tyvars, ty) = Scheme.dest s
in
T {kind = k,
node = (case Type.deEta (ty, tyvars) of
NONE => Scheme s
| SOME c => Tycon c)}
end
fun isTycon s =
case node s of
Datatype _ => false
| Scheme _ => false
| Tycon _ => true
fun toTyconOpt s =
case node s of
Datatype {tycon, ...} => SOME tycon
| Scheme _ => NONE
| Tycon c => SOME c
fun tycon (c, kind) = T {kind = kind,
node = Tycon c}
end
1.1 mlton/mlton/elaborate/type-str.sig
Index: type-str.sig
===================================================================
(* Copyright (C) 1999-2002 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 TYPE_STR_STRUCTS =
sig
structure Con:
sig
type t
val layout: t -> Layout.t
val newNoname: unit -> t
end
structure Kind: TYCON_KIND
structure Name:
sig
type t
val layout: t -> Layout.t
end
structure Tycon:
sig
structure AdmitsEquality: ADMITS_EQUALITY
type t
val admitsEquality: t -> AdmitsEquality.t ref
val arrow: t
val equals: t * t -> bool
val exn: t
val layout: t -> Layout.t
val layoutApp:
t * (Layout.t * {isChar: bool, needsParen: bool}) vector
-> Layout.t * {isChar: bool, needsParen: bool}
val make: unit -> t
end
structure Record: RECORD
structure Tyvar: TYVAR
structure Type:
sig
type t
val arrow: t * t -> t
val bogus: t
val con: Tycon.t * t vector -> t
val deEta: t * Tyvar.t vector -> Tycon.t option
val exn: t
val hom: t * {con: Tycon.t * 'a vector -> 'a,
record: 'a Record.t -> 'a,
var: Tyvar.t -> 'a} -> 'a
val layout: t -> Layout.t
val record: t Record.t -> t
val var: Tyvar.t -> t
end
structure Scheme:
sig
type t
val admitsEquality: t -> bool
val apply: t * Type.t vector -> Type.t
val bogus: unit -> t
val dest: t -> Tyvar.t vector * Type.t
val layout: t -> Layout.t
val make: Tyvar.t vector * Type.t -> t
val ty: t -> Type.t
end
end
signature TYPE_STR =
sig
include TYPE_STR_STRUCTS
structure Cons:
sig
datatype t = T of {con: Con.t,
name: Name.t,
scheme: Scheme.t} vector
val empty: t
val layout: t -> Layout.t
end
type t
datatype node =
Datatype of {cons: Cons.t,
tycon: Tycon.t}
| Scheme of Scheme.t
| Tycon of Tycon.t
val abs: t -> t
val apply: t * Type.t vector -> Type.t
val bogus: Kind.t -> t
val cons: t -> Cons.t
val data: Tycon.t * Kind.t * Cons.t -> t
val def: Scheme.t * Kind.t -> t
val kind: t -> Kind.t
val layout: t -> Layout.t
val node: t -> node
val toTyconOpt: t -> Tycon.t option (* NONE on Scheme *)
val tycon: Tycon.t * Kind.t -> t
end
1.15 +1 -14 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- ml.grm 13 Oct 2003 22:03:06 -0000 1.14
+++ ml.grm 7 Nov 2003 00:21:29 -0000 1.15
@@ -151,10 +151,6 @@
type typdesc = {tyvars: Tyvar.t vector,
tycon: Tycon.t}
-type typdef = {tyvars: Tyvar.t vector,
- tycon: Tycon.t,
- ty: Type.t}
-
type valdesc = Var.t * Type.t
type exndesc = Con.t * Type.t option
@@ -369,8 +365,6 @@
| tynode of Type.node
| typBind of TypBind.t
| typBind' of TypBind.node
- | typdef of typdef
- | typdefs of typdef list
| typdesc of typdesc
| typdescs of typdesc list
| tyvar of Tyvar.t
@@ -587,7 +581,7 @@
specnode : VAL valdescs (Spec.Val valdescs)
| TYPE typdescs (Spec.Type typdescs)
- | TYPE typdefs (Spec.TypeDefs typdefs)
+ | TYPE typBind (Spec.TypeDefs typBind)
| EQTYPE typdescs (Spec.Eqtype typdescs)
| DATATYPE datatypeRhsNoWithtype (Spec.Datatype datatypeRhsNoWithtype)
| EXCEPTION exndescs (Spec.Exception exndescs)
@@ -620,13 +614,6 @@
strdescs'' : strdescs' (strdescs')
| AND wherespec strdescs'' (cons1 (wherespec, strdescs''))
-
-typdefs : typdef ([typdef])
- | typdef AND typdefs (typdef :: typdefs)
-
-typdef : tyvars tycon EQUALOP ty ({tyvars = tyvars,
- tycon = tycon,
- ty = ty})
typdescs : typdesc ([typdesc])
| typdesc AND typdescs (typdesc :: typdescs)
1.8 +1 -1 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- compile.fun 16 Oct 2003 22:37:12 -0000 1.7
+++ compile.fun 7 Nov 2003 00:21:29 -0000 1.8
@@ -253,7 +253,7 @@
(E, Tycon.toAst tycon,
TypeStr.data (tycon,
TypeStr.Kind.Arity (Vector.length tyvars),
- cs))
+ TypeStr.Cons.T cs))
end)
val _ =
extendTycon (E, Ast.Tycon.fromString ("unit", Region.bogus),
1.6 +0 -12 mlton/mlton/main/main.fun
Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- main.fun 16 Oct 2003 22:37:12 -0000 1.5
+++ main.fun 7 Nov 2003 00:21:29 -0000 1.6
@@ -792,16 +792,4 @@
[root, file] => exportNJ (root, file)
| _ => Error.bug "usage: exportMLton root file"
-val _ =
- let
- open Trace.Immediate
- in
- debug := Out Out.error
- ; flagged ()
-(* ; on ["admitsEquality"] *)
-(* ; on ["elaborateDec"] *)
-(* ; on ["extendVar"] *)
-(* ; on ["elaborateExp"] *)
-(* ; on ["unify", "Scheme.instantiate"] *)
- end
end
1.158 +15 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.157
retrieving revision 1.158
diff -u -r1.157 -r1.158
--- main.sml 9 Oct 2003 18:17:33 -0000 1.157
+++ main.sml 7 Nov 2003 00:21:29 -0000 1.158
@@ -1 +1,16 @@
structure Main = Main ()
+
+val _ =
+ let
+ open Trace.Immediate
+ in
+ debug := Out Out.error
+ ; flagged ()
+(* ; on ["elaborateTopdec"] *)
+(* ; on ["cut", "realize", "TypeStr.toEnv"] *)
+(* ; on ["elaborateSigexp"] *)
+(* ; on ["elaborateSigexp", "elaborateSpec"] *)
+(* ; on ["elaborateType"] *)
+(* ; on ["handleStr", "handleType", "handleVal"] *)
+(* ; on ["TypeStr.toEnv", "TypeStr.fromEnv"] *)
+ end
1.2 +14 -9 mlton/regression/where.sml
Index: where.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/where.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- where.sml 5 Oct 2001 19:07:42 -0000 1.1
+++ where.sml 7 Nov 2003 00:21:29 -0000 1.2
@@ -8,12 +8,17 @@
type s = t
end where type s = int;
-signature T = (* due to Marin Elsman, also see SML/NJ bug 1330 *)
-sig
- type s
- structure U :
- sig
- type 'a t
- type u = (int * real) t
- end where type 'a t = s
-end where type U.u = int;
+(* MLton doesn't get this right yet.
+ * Due to Marin Elsman, also see SML/NJ bug 1330.
+ *
+ * signature T =
+ * sig
+ * type s
+ * structure U :
+ * sig
+ * type 'a t
+ * type u = (int * real) t
+ * end where type 'a t = s
+ * end where type U.u = int;
+ *
+ *)