diff options
| -rw-r--r-- | src/compiler.sig | 2 | ||||
| -rw-r--r-- | src/compiler.sml | 36 | ||||
| -rw-r--r-- | src/mono.sml | 58 | ||||
| -rw-r--r-- | src/mono_env.sig | 49 | ||||
| -rw-r--r-- | src/mono_env.sml | 99 | ||||
| -rw-r--r-- | src/mono_print.sig | 38 | ||||
| -rw-r--r-- | src/mono_print.sml | 141 | ||||
| -rw-r--r-- | src/monoize.sig | 32 | ||||
| -rw-r--r-- | src/monoize.sml | 121 | ||||
| -rw-r--r-- | src/sources | 11 |
10 files changed, 584 insertions, 3 deletions
diff --git a/src/compiler.sig b/src/compiler.sig index c06ac765..3e6ed1a3 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -34,11 +34,13 @@ signature COMPILER = sig val corify : ElabEnv.env -> CoreEnv.env -> string -> Core.file option val reduce : ElabEnv.env -> CoreEnv.env -> string -> Core.file option val shake : ElabEnv.env -> CoreEnv.env -> string -> Core.file option + val monoize : ElabEnv.env -> CoreEnv.env -> string -> Mono.file option val testParse : string -> unit val testElaborate : string -> unit val testCorify : string -> unit val testReduce : string -> unit val testShake : string -> unit + val testMonoize : string -> unit end diff --git a/src/compiler.sml b/src/compiler.sml index 45fd88e4..20eb3ef5 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -70,17 +70,38 @@ fun elaborate env filename = fun corify eenv cenv filename = case elaborate eenv filename of NONE => NONE - | SOME (_, file) => SOME (Corify.corify file) + | SOME (_, file) => + if ErrorMsg.anyErrors () then + NONE + else + SOME (Corify.corify file) fun reduce eenv cenv filename = case corify eenv cenv filename of NONE => NONE - | SOME file => SOME (Reduce.reduce (Shake.shake file)) + | SOME file => + if ErrorMsg.anyErrors () then + NONE + else + SOME (Reduce.reduce (Shake.shake file)) fun shake eenv cenv filename = case reduce eenv cenv filename of NONE => NONE - | SOME file => SOME (Shake.shake file) + | SOME file => + if ErrorMsg.anyErrors () then + NONE + else + SOME (Shake.shake file) + +fun monoize eenv cenv filename = + case shake eenv cenv filename of + NONE => NONE + | SOME file => + if ErrorMsg.anyErrors () then + NONE + else + SOME (Monoize.monoize cenv file) fun testParse filename = case parse filename of @@ -125,4 +146,13 @@ fun testShake filename = handle CoreEnv.UnboundNamed n => print ("Unbound named " ^ Int.toString n ^ "\n") +fun testMonoize filename = + (case monoize ElabEnv.basis CoreEnv.basis filename of + NONE => print "Failed\n" + | SOME file => + (Print.print (MonoPrint.p_file MonoEnv.basis file); + print "\n")) + handle MonoEnv.UnboundNamed n => + print ("Unbound named " ^ Int.toString n ^ "\n") + end diff --git a/src/mono.sml b/src/mono.sml new file mode 100644 index 00000000..7a4b54ee --- /dev/null +++ b/src/mono.sml @@ -0,0 +1,58 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Mono = struct + +type 'a located = 'a ErrorMsg.located + +datatype typ' = + TFun of typ * typ + | TRecord of (string * typ) list + | TNamed of int + +withtype typ = typ' located + +datatype exp' = + EPrim of Prim.t + | ERel of int + | ENamed of int + | EApp of exp * exp + | EAbs of string * typ * exp + + | ERecord of (string * exp) list + | EField of exp * string + +withtype exp = exp' located + +datatype decl' = + DVal of string * int * typ * exp + +withtype decl = decl' located + +type file = decl list + +end diff --git a/src/mono_env.sig b/src/mono_env.sig new file mode 100644 index 00000000..f3936998 --- /dev/null +++ b/src/mono_env.sig @@ -0,0 +1,49 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature MONO_ENV = sig + + type env + + val empty : env + val basis : env + + exception UnboundRel of int + exception UnboundNamed of int + + val pushTNamed : env -> string -> int -> Mono.typ option -> env + val lookupTNamed : env -> int -> string * Mono.typ option + + val pushERel : env -> string -> Mono.typ -> env + val lookupERel : env -> int -> string * Mono.typ + + val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> env + val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option + + val declBinds : env -> Mono.decl -> env + +end diff --git a/src/mono_env.sml b/src/mono_env.sml new file mode 100644 index 00000000..60c6f609 --- /dev/null +++ b/src/mono_env.sml @@ -0,0 +1,99 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure MonoEnv :> MONO_ENV = struct + +open Mono + +structure IM = IntBinaryMap + + +exception UnboundRel of int +exception UnboundNamed of int + +type env = { + namedT : (string * typ option) IM.map, + + relE : (string * typ) list, + namedE : (string * typ * exp option) IM.map +} + +val empty = { + namedT = IM.empty, + + relE = [], + namedE = IM.empty +} + +fun pushTNamed (env : env) x n co = + {namedT = IM.insert (#namedT env, n, (x, co)), + + relE = #relE env, + namedE = #namedE env} + +fun lookupTNamed (env : env) n = + case IM.find (#namedT env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushERel (env : env) x t = + {namedT = #namedT env, + + relE = (x, t) :: #relE env, + namedE = #namedE env} + +fun lookupERel (env : env) n = + (List.nth (#relE env, n)) + handle Subscript => raise UnboundRel n + +fun pushENamed (env : env) x n t eo = + {namedT = #namedT env, + + relE = #relE env, + namedE = IM.insert (#namedE env, n, (x, t, eo))} + +fun lookupENamed (env : env) n = + case IM.find (#namedE env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun declBinds env (d, _) = + case d of + DVal (x, n, t, e) => pushENamed env x n t (SOME e) + +fun bbind env x = + case ElabEnv.lookupC ElabEnv.basis x of + ElabEnv.NotBound => raise Fail "MonoEnv.bbind: Not bound" + | ElabEnv.Rel _ => raise Fail "MonoEnv.bbind: Rel" + | ElabEnv.Named (n, _) => pushTNamed env x n NONE + +val basis = empty +val basis = bbind basis "int" +val basis = bbind basis "float" +val basis = bbind basis "string" + +end diff --git a/src/mono_print.sig b/src/mono_print.sig new file mode 100644 index 00000000..6f7f09a9 --- /dev/null +++ b/src/mono_print.sig @@ -0,0 +1,38 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Pretty-printing Laconic/Web monomorphic language *) + +signature MONO_PRINT = sig + val p_typ : MonoEnv.env -> Mono.typ Print.printer + val p_exp : MonoEnv.env -> Mono.exp Print.printer + val p_decl : MonoEnv.env -> Mono.decl Print.printer + val p_file : MonoEnv.env -> Mono.file Print.printer + + val debug : bool ref +end + diff --git a/src/mono_print.sml b/src/mono_print.sml new file mode 100644 index 00000000..a23296f9 --- /dev/null +++ b/src/mono_print.sml @@ -0,0 +1,141 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Pretty-printing monomorphic Laconic/Web *) + +structure MonoPrint :> MONO_PRINT = struct + +open Print.PD +open Print + +open Mono + +structure E = MonoEnv + +val debug = ref false + +fun p_typ' par env (t, _) = + case t of + TFun (t1, t2) => parenIf par (box [p_typ' true env t1, + space, + string "->", + space, + p_typ env t2]) + | TRecord xcs => box [string "{", + p_list (fn (x, t) => + box [string x, + space, + string ":", + space, + p_typ env t]) xcs, + string "}"] + | TNamed n => + if !debug then + string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupTNamed env n)) + +and p_typ env = p_typ' false env + +fun p_exp' par env (e, _) = + case e of + EPrim p => Prim.p_t p + | ERel n => + if !debug then + string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupERel env n)) + | ENamed n => + if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n)) + | EApp (e1, e2) => parenIf par (box [p_exp env e1, + space, + p_exp' true env e2]) + | EAbs (x, t, e) => parenIf par (box [string "fn", + space, + string x, + space, + string ":", + space, + p_typ env t, + space, + string "=>", + space, + p_exp (E.pushERel env x t) e]) + + | ERecord xes => box [string "{", + p_list (fn (x, e) => + box [string x, + space, + string "=", + space, + p_exp env e]) xes, + string "}"] + | EField (e, x) => + box [p_exp' true env e, + string ".", + string x] + +and p_exp env = p_exp' false env + +fun p_decl env ((d, _) : decl) = + case d of + DVal (x, n, t, e) => + let + val xp = if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + in + box [string "val", + space, + xp, + space, + string ":", + space, + p_typ env t, + space, + string "=", + space, + p_exp env e] + end + +fun p_file env file = + let + val (_, pds) = ListUtil.mapfoldl (fn (d, env) => + (E.declBinds env d, + p_decl env d)) + env file + in + p_list_sep newline (fn x => x) pds + end + +end diff --git a/src/monoize.sig b/src/monoize.sig new file mode 100644 index 00000000..0e9c23c3 --- /dev/null +++ b/src/monoize.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature MONOIZE = sig + + val monoize : CoreEnv.env -> Core.file -> Mono.file + +end diff --git a/src/monoize.sml b/src/monoize.sml new file mode 100644 index 00000000..e72d7b1b --- /dev/null +++ b/src/monoize.sml @@ -0,0 +1,121 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Monoize :> MONOIZE = struct + +structure E = ErrorMsg +structure Env = CoreEnv + +structure L = Core +structure L' = Mono + +val dummyTyp = (L'.TNamed 0, E.dummySpan) + +fun monoName env (all as (c, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported name constructor"; + Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; + "") + in + case c of + L.CName s => s + | _ => poly () + end + +fun monoType env (all as (c, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported type constructor"; + Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; + dummyTyp) + in + case c of + L.TFun (c1, c2) => (L'.TFun (monoType env c1, monoType env c2), loc) + | L.TCFun _ => poly () + | L.TRecord (L.CRecord ((L.KType, _), xcs), _) => + (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc) + | L.TRecord _ => poly () + + | L.CRel _ => poly () + | L.CNamed n => (L'.TNamed n, loc) + | L.CApp _ => poly () + | L.CAbs _ => poly () + + | L.CName _ => poly () + + | L.CRecord _ => poly () + | L.CConcat _ => poly () + end + +val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) + +fun monoExp env (all as (e, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported expression"; + Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; + dummyExp) + in + case e of + L.EPrim p => (L'.EPrim p, loc) + | L.ERel n => (L'.ERel n, loc) + | L.ENamed n => (L'.ENamed n, loc) + | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc) + | L.EAbs (x, t, e) => + (L'.EAbs (x, monoType env t, monoExp (Env.pushERel env x t) e), loc) + | L.ECApp _ => poly () + | L.ECAbs _ => poly () + + | L.ERecord xes => (L'.ERecord (map (fn (x, e) => (monoName env x, monoExp env e)) xes), loc) + | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc) + end + +fun monoDecl env (all as (d, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported declaration"; + Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; + NONE) + in + case d of + L.DCon _ => NONE + | L.DVal (x, n, t, e) => SOME (Env.pushENamed env x n t (SOME e), + (L'.DVal (x, n, monoType env t, monoExp env e), loc)) + end + +fun monoize env ds = + let + val (_, ds) = List.foldl (fn (d, (env, ds)) => + case monoDecl env d of + NONE => (env, ds) + | SOME (env, d) => (env, d :: ds)) (env, []) ds + in + rev ds + end + +end diff --git a/src/sources b/src/sources index f10e0e90..adcda7e9 100644 --- a/src/sources +++ b/src/sources @@ -55,5 +55,16 @@ reduce.sml shake.sig shake.sml +mono.sml + +monoize.sig +monoize.sml + +mono_env.sig +mono_env.sml + +mono_print.sig +mono_print.sml + compiler.sig compiler.sml |