summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/mono_fm.sig22
-rw-r--r--src/mono_fm.sml115
-rw-r--r--src/monoize.sml134
-rw-r--r--src/sources3
4 files changed, 148 insertions, 126 deletions
diff --git a/src/mono_fm.sig b/src/mono_fm.sig
new file mode 100644
index 00000000..a72a5da7
--- /dev/null
+++ b/src/mono_fm.sig
@@ -0,0 +1,22 @@
+signature MONO_FM = sig
+ type t
+
+ type vr = string * int * Mono.typ * Mono.exp * string
+
+ datatype foo_kind =
+ Attr
+ | Url
+
+ val empty : int -> t
+
+ val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
+ val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int
+ val enter : t -> t
+ val decls : t -> Mono.decl list
+
+ val freshName : t -> int * t
+
+ (* TODO: don't expose raw references if possible. *)
+ val nextPvar : int ref
+ val postMonoize : t ref
+end
diff --git a/src/mono_fm.sml b/src/mono_fm.sml
new file mode 100644
index 00000000..d7e9e001
--- /dev/null
+++ b/src/mono_fm.sml
@@ -0,0 +1,115 @@
+(* TODO: better name than "fm"? *)
+structure MonoFm : MONO_FM = struct
+
+open Mono
+
+type vr = string * int * typ * exp * string
+
+datatype foo_kind =
+ Attr
+ | Url
+
+structure IM = IntBinaryMap
+
+structure M = BinaryMapFn(struct
+ type ord_key = foo_kind
+ fun compare x =
+ case x of
+ (Attr, Attr) => EQUAL
+ | (Attr, _) => LESS
+ | (_, Attr) => GREATER
+
+ | (Url, Url) => EQUAL
+ end)
+
+structure TM = BinaryMapFn(struct
+ type ord_key = typ
+ val compare = MonoUtil.Typ.compare
+ end)
+
+type t = {
+ count : int,
+ map : int IM.map M.map,
+ listMap : int TM.map M.map,
+ decls : vr list
+}
+
+val nextPvar = ref 0
+
+fun empty count = {
+ count = count,
+ map = M.empty,
+ listMap = M.empty,
+ decls = []
+}
+
+fun chooseNext count =
+ let
+ val n = !nextPvar
+ in
+ if count < n then
+ (count, count+1)
+ else
+ (nextPvar := n + 1;
+ (n, n+1))
+ end
+
+fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
+fun freshName {count, map, listMap, decls} =
+ let
+ val (next, count) = chooseNext count
+ in
+ (next, {count = count , map = map, listMap = listMap, decls = decls})
+ end
+fun decls ({decls, ...} : t) =
+ case decls of
+ [] => []
+ | _ => [(DValRec decls, ErrorMsg.dummySpan)]
+
+fun lookup (t as {count, map, listMap, decls}) k n thunk =
+ let
+ val im = Option.getOpt (M.find (map, k), IM.empty)
+ in
+ case IM.find (im, n) of
+ NONE =>
+ let
+ val n' = count
+ val (d, {count, map, listMap, decls}) =
+ thunk count {count = count + 1,
+ map = M.insert (map, k, IM.insert (im, n, n')),
+ listMap = listMap,
+ decls = decls}
+ in
+ ({count = count,
+ map = map,
+ listMap = listMap,
+ decls = d :: decls}, n')
+ end
+ | SOME n' => (t, n')
+ end
+
+fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
+ let
+ val tm = Option.getOpt (M.find (listMap, k), TM.empty)
+ in
+ case TM.find (tm, tp) of
+ NONE =>
+ let
+ val n' = count
+ val (d, {count, map, listMap, decls}) =
+ thunk count {count = count + 1,
+ map = map,
+ listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
+ decls = decls}
+ in
+ ({count = count,
+ map = map,
+ listMap = listMap,
+ decls = d :: decls}, n')
+ end
+ | SOME n' => (t, n')
+ end
+
+val postMonoize : t ref = ref (empty 0)
+
+end
diff --git a/src/monoize.sml b/src/monoize.sml
index d8c4d276..4bd3aff2 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -50,7 +50,7 @@ structure RM = BinaryMapFn(struct
(L'.TRecord r2, E.dummySpan))
end)
-val nextPvar = ref 0
+val nextPvar = MonoFm.nextPvar
val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map)
val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list)
val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list)
@@ -374,131 +374,12 @@ fun monoType env =
val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
-structure IM = IntBinaryMap
-
-datatype foo_kind =
- Attr
- | Url
+structure Fm = MonoFm
fun fk2s fk =
case fk of
- Attr => "attr"
- | Url => "url"
-
-type vr = string * int * L'.typ * L'.exp * string
-
-structure Fm :> sig
- type t
-
- val empty : int -> t
-
- val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
- val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> vr * t) -> t * int
- val enter : t -> t
- val decls : t -> L'.decl list
-
- val freshName : t -> int * t
-end = struct
-
-structure M = BinaryMapFn(struct
- type ord_key = foo_kind
- fun compare x =
- case x of
- (Attr, Attr) => EQUAL
- | (Attr, _) => LESS
- | (_, Attr) => GREATER
-
- | (Url, Url) => EQUAL
- end)
-
-structure TM = BinaryMapFn(struct
- type ord_key = L'.typ
- val compare = MonoUtil.Typ.compare
- end)
-
-type t = {
- count : int,
- map : int IM.map M.map,
- listMap : int TM.map M.map,
- decls : vr list
-}
-
-fun empty count = {
- count = count,
- map = M.empty,
- listMap = M.empty,
- decls = []
-}
-
-fun chooseNext count =
- let
- val n = !nextPvar
- in
- if count < n then
- (count, count+1)
- else
- (nextPvar := n + 1;
- (n, n+1))
- end
-
-fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
-fun freshName {count, map, listMap, decls} =
- let
- val (next, count) = chooseNext count
- in
- (next, {count = count , map = map, listMap = listMap, decls = decls})
- end
-fun decls ({decls, ...} : t) =
- case decls of
- [] => []
- | _ => [(L'.DValRec decls, ErrorMsg.dummySpan)]
-
-fun lookup (t as {count, map, listMap, decls}) k n thunk =
- let
- val im = Option.getOpt (M.find (map, k), IM.empty)
- in
- case IM.find (im, n) of
- NONE =>
- let
- val n' = count
- val (d, {count, map, listMap, decls}) =
- thunk count {count = count + 1,
- map = M.insert (map, k, IM.insert (im, n, n')),
- listMap = listMap,
- decls = decls}
- in
- ({count = count,
- map = map,
- listMap = listMap,
- decls = d :: decls}, n')
- end
- | SOME n' => (t, n')
- end
-
-fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
- let
- val tm = Option.getOpt (M.find (listMap, k), TM.empty)
- in
- case TM.find (tm, tp) of
- NONE =>
- let
- val n' = count
- val (d, {count, map, listMap, decls}) =
- thunk count {count = count + 1,
- map = map,
- listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
- decls = decls}
- in
- ({count = count,
- map = map,
- listMap = listMap,
- decls = d :: decls}, n')
- end
- | SOME n' => (t, n')
- end
-
-end
-
+ Fm.Attr => "attr"
+ | Fm.Url => "url"
fun capitalize s =
if s = "" then
@@ -677,8 +558,8 @@ fun fooifyExp fk env =
fooify
end
-val attrifyExp = fooifyExp Attr
-val urlifyExp = fooifyExp Url
+val attrifyExp = fooifyExp Fm.Attr
+val urlifyExp = fooifyExp Fm.Url
val urlifiedUnit =
let
@@ -4738,7 +4619,7 @@ fun monoize env file =
val mname = CoreUtil.File.maxName file + 1
val () = nextPvar := mname
- val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
+ val (_, fm, ds) = List.foldl (fn (d, (env, fm, ds)) =>
case #1 d of
L.DDatabase s =>
let
@@ -4786,6 +4667,7 @@ fun monoize env file =
pvars := RM.empty;
pvarDefs := [];
pvarOldDefs := [];
+ Fm.postMonoize := fm;
(rev ds, [])
end
diff --git a/src/sources b/src/sources
index f0914bdf..e6a361ce 100644
--- a/src/sources
+++ b/src/sources
@@ -168,6 +168,9 @@ $(SRC)/mono_env.sml
$(SRC)/mono_print.sig
$(SRC)/mono_print.sml
+$(SRC)/mono_fm.sig
+$(SRC)/mono_fm.sml
+
$(SRC)/sql.sig
$(SRC)/sql.sml
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-07 00:59:51 +0000