diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2008-07-13 10:17:06 -0400 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2008-07-13 10:17:06 -0400 |
| commit | 3316f3c317e587a5fc2ecf38f061a72b48e3b94e (patch) | |
| tree | fae8c92c195e5f7976352a337017d285e729f859 /src | |
| parent | 7281dbb2fc2a5f50c1049bad629f330e2ff3f7ca (diff) | |
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
Diffstat (limited to 'src')
49 files changed, 337 insertions, 1661 deletions
diff --git a/src/cjr.sml b/src/cjr.sml index d22b38f4..a47c77fe 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -31,8 +31,7 @@ type 'a located = 'a ErrorMsg.located datatype typ' = TTop - | TFun - | TCode of typ * typ + | TFun of typ * typ | TRecord of int | TNamed of int | TFfi of string * string @@ -45,14 +44,11 @@ datatype exp' = | ENamed of int | EFfi of string * string | EFfiApp of string * string * exp list - | ECode of int | EApp of exp * exp | ERecord of int * (string * exp) list | EField of exp * string - | ELet of (string * typ * exp) list * exp - | EWrite of exp | ESeq of exp * exp @@ -61,10 +57,10 @@ withtype exp = exp' located datatype decl' = DStruct of int * (string * typ) list | DVal of string * int * typ * exp - | DFun of int * string * typ * typ * exp + | DFun of string * int * string * typ * typ * exp withtype decl = decl' located -type file = decl list * ((string * typ) list * exp) list +type file = decl list * int list end diff --git a/src/cjr_env.sig b/src/cjr_env.sig index 2aa785d5..36c3d682 100644 --- a/src/cjr_env.sig +++ b/src/cjr_env.sig @@ -47,9 +47,6 @@ signature CJR_ENV = sig val pushENamed : env -> string -> int -> Cjr.typ -> env val lookupENamed : env -> int -> string * Cjr.typ - val pushF : env -> int -> string -> Cjr.typ -> Cjr.typ -> env - val lookupF : env -> int -> string * Cjr.typ * Cjr.typ - val pushStruct : env -> int -> (string * Cjr.typ) list -> env val lookupStruct : env -> int -> (string * Cjr.typ) list diff --git a/src/cjr_env.sml b/src/cjr_env.sml index de1c31a1..686c99b1 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -44,7 +44,6 @@ type env = { relE : (string * typ) list, namedE : (string * typ) IM.map, - F : (string * typ * typ) IM.map, structs : (string * typ) list IM.map } @@ -55,7 +54,6 @@ val empty = { relE = [], namedE = IM.empty, - F = IM.empty, structs = IM.empty } @@ -66,7 +64,6 @@ fun pushTNamed (env : env) x n co = relE = #relE env, namedE = #namedE env, - F = #F env, structs = #structs env} fun lookupTNamed (env : env) n = @@ -81,7 +78,6 @@ fun pushERel (env : env) x t = relE = (x, t) :: #relE env, namedE = #namedE env, - F = #F env, structs = #structs env} fun lookupERel (env : env) n = @@ -99,7 +95,6 @@ fun pushENamed (env : env) x n t = relE = #relE env, namedE = IM.insert (#namedE env, n, (x, t)), - F = #F env, structs = #structs env} fun lookupENamed (env : env) n = @@ -107,21 +102,6 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x -fun pushF (env : env) n x dom ran = - {namedT = #namedT env, - - numRelE = #numRelE env, - relE = #relE env, - namedE = #namedE env, - - F = IM.insert (#F env, n, (x, dom, ran)), - structs = #structs env} - -fun lookupF (env : env) n = - case IM.find (#F env, n) of - NONE => raise UnboundF n - | SOME x => x - fun pushStruct (env : env) n xts = {namedT = #namedT env, @@ -129,7 +109,6 @@ fun pushStruct (env : env) n xts = relE = #relE env, namedE = #namedE env, - F = #F env, structs = IM.insert (#structs env, n, xts)} fun lookupStruct (env : env) n = @@ -137,10 +116,10 @@ fun lookupStruct (env : env) n = NONE => raise UnboundStruct n | SOME x => x -fun declBinds env (d, _) = +fun declBinds env (d, loc) = case d of DVal (x, n, t, _) => pushENamed env x n t - | DFun (n, x, dom, ran, _) => pushF env n x dom ran + | DFun (fx, n, _, dom, ran, _) => pushENamed env fx n (TFun (dom, ran), loc) | DStruct (n, xts) => pushStruct env n xts end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 44e9f847..32c43d23 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -44,16 +44,13 @@ val dummyTyp = (TNamed 0, ErrorMsg.dummySpan) fun p_typ' par env (t, loc) = case t of TTop => string "void*" - | TFun => - (EM.errorAt loc "Undetermined function type"; - string "?->") - | TCode (t1, t2) => parenIf par (box [p_typ' true env t2, - space, - string "(*)", - space, - string "(", - p_typ env t1, - string ")"]) + | TFun (t1, t2) => parenIf par (box [p_typ' true env t2, + space, + string "(*)", + space, + string "(", + p_typ env t1, + string ")"]) | TRecord i => box [string "struct", space, string "__lws_", @@ -68,13 +65,16 @@ and p_typ env = p_typ' false env fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1)) handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) +fun p_enamed env n = + string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n) + handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n) + fun p_exp' par env (e, _) = case e of EPrim p => Prim.p_t p | ERel n => p_rel env n - | ENamed n => - (string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n) - handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)) + | ENamed n => p_enamed env n + | EFfi (m, x) => box [string "lw_", string m, string "_", string x] | EFfiApp (m, x, es) => box [string "lw_", string m, @@ -83,7 +83,6 @@ fun p_exp' par env (e, _) = string "(", p_list (p_exp env) es, string ")"] - | ECode n => string ("__lwc_" ^ Int.toString n) | EApp (e1, e2) => parenIf par (box [p_exp' true env e1, string "(", p_exp env e2, @@ -112,36 +111,6 @@ fun p_exp' par env (e, _) = string ".", string x] - | ELet (xes, e) => - let - val (env, pps) = foldl (fn ((x, t, e), (env, pps)) => - let - val env' = E.pushERel env x t - in - (env', - List.revAppend ([p_typ env t, - space, - p_rel env' 0, - space, - string "=", - space, - p_exp env e, - string ";", - newline], - pps)) - end) - (env, []) xes - in - box [string "({", - newline, - box (rev pps), - p_exp env e, - space, - string ";", - newline, - string "})"] - end - | EWrite e => box [string "(lw_write(", p_exp env e, string "), lw_unit_v)"] @@ -180,7 +149,7 @@ fun p_decl env ((d, _) : decl) = space, p_exp env e, string ";"] - | DFun (n, x, dom, ran, e) => + | DFun (fx, n, x, dom, ran, e) => let val env' = E.pushERel env x dom in @@ -188,7 +157,7 @@ fun p_decl env ((d, _) : decl) = space, p_typ env ran, space, - string ("__lwc_" ^ Int.toString n), + string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), string "(", p_typ env dom, space, @@ -204,46 +173,8 @@ fun p_decl env ((d, _) : decl) = string "}"] end -fun p_page env (xts, (e, loc)) = - case e of - ERecord (_, xes) => - let - fun read x = ListUtil.search (fn (x', e) => if x' = x then SOME e else NONE) xes - in - case (read "code", read "env") of - (SOME code, SOME envx) => - (case #1 code of - ECode i => - let - val (_, (dom, _), _) = E.lookupF env i - in - case dom of - TRecord ri => - let - val axts = E.lookupStruct env ri - fun read x = ListUtil.search (fn (x', t) => if x' = x then SOME t else NONE) axts - in - case read "arg" of - NONE => string "Page handler is too complicated! [5]" - | SOME (at, _) => - case at of - TRecord ari => - let - val r = (ERecord (ri, [("env", envx), - ("arg", (ERecord (ari, []), loc))]), loc) - in - box [p_exp env (EApp (code, r), loc), - string ";"] - end - | _ => string "Page handler is too complicated! [6]" - end - | _ => string "Page handler is too complicated! [4]" - end - | _ => string "Page handler is too complicated! [3]") - - | _ => string "Page handler is too complicated! [1]" - end - | _ => string "Page handler is too complicated! [2]" +fun p_page env n = box [p_enamed env n, + string "(lw_unit_v);"] fun p_file env (ds, ps) = let diff --git a/src/cjrize.sig b/src/cjrize.sig index 44bf4fd2..fb8d37f5 100644 --- a/src/cjrize.sig +++ b/src/cjrize.sig @@ -27,6 +27,6 @@ signature CJRIZE = sig - val cjrize : Flat.file -> Cjr.file + val cjrize : Mono.file -> Cjr.file end diff --git a/src/cjrize.sml b/src/cjrize.sml index da436720..52b1b4ac 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -27,7 +27,7 @@ structure Cjrize :> CJRIZE = struct -structure L = Flat +structure L = Mono structure L' = Cjr structure Sm :> sig @@ -41,7 +41,7 @@ end = struct structure FM = BinaryMapFn(struct type ord_key = L.typ - val compare = FlatUtil.Typ.compare + val compare = MonoUtil.Typ.compare end) type t = int * int FM.map * (int * (string * L'.typ) list) list @@ -63,20 +63,12 @@ end fun cifyTyp ((t, loc), sm) = case t of - L.TTop => ((L'.TTop, loc), sm) - | L.TFun (t1, t2) => - let - val (_, sm) = cifyTyp (t1, sm) - val (_, sm) = cifyTyp (t2, sm) - in - ((L'.TFun, loc), sm) - end - | L.TCode (t1, t2) => + L.TFun (t1, t2) => let val (t1, sm) = cifyTyp (t1, sm) val (t2, sm) = cifyTyp (t2, sm) in - ((L'.TCode (t1, t2), loc), sm) + ((L'.TFun (t1, t2), loc), sm) end | L.TRecord xts => let @@ -95,6 +87,8 @@ fun cifyTyp ((t, loc), sm) = | L.TNamed n => ((L'.TNamed n, loc), sm) | L.TFfi mx => ((L'.TFfi mx, loc), sm) +val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan) + fun cifyExp ((e, loc), sm) = case e of L.EPrim p => ((L'.EPrim p, loc), sm) @@ -107,7 +101,6 @@ fun cifyExp ((e, loc), sm) = in ((L'.EFfiApp (m, x, es), loc), sm) end - | L.ECode n => ((L'.ECode n, loc), sm) | L.EApp (e1, e2) => let val (e1, sm) = cifyExp (e1, sm) @@ -115,6 +108,8 @@ fun cifyExp ((e, loc), sm) = in ((L'.EApp (e1, e2), loc), sm) end + | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation"; + (dummye, sm)) | L.ERecord xes => let @@ -143,21 +138,6 @@ fun cifyExp ((e, loc), sm) = ((L'.EField (e, x), loc), sm) end - | L.ELet (xes, e) => - let - val (xes, sm) = ListUtil.foldlMap (fn ((x, t, e), sm) => - let - val (t, sm) = cifyTyp (t, sm) - val (e, sm) = cifyExp (e, sm) - in - ((x, t, e), sm) - end) - sm xes - val (e, sm) = cifyExp (e, sm) - in - ((L'.ELet (xes, e), loc), sm) - end - | L.EStrcat _ => raise Fail "Cjrize EStrcat" | L.EWrite e => @@ -177,34 +157,31 @@ fun cifyExp ((e, loc), sm) = fun cifyDecl ((d, loc), sm) = case d of - L.DVal (x, n, t, e) => + L.DVal (x, n, t, e, _) => let val (t, sm) = cifyTyp (t, sm) - val (e, sm) = cifyExp (e, sm) - in - (SOME (L'.DVal (x, n, t, e), loc), NONE, sm) - end - | L.DFun (n, x, dom, ran, e) => - let - val (dom, sm) = cifyTyp (dom, sm) - val (ran, sm) = cifyTyp (ran, sm) - val (e, sm) = cifyExp (e, sm) - in - (SOME (L'.DFun (n, x, dom, ran, e), loc), NONE, sm) - end - | L.DPage (xts, e) => - let - val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => - let - val (t, sm) = cifyTyp (t, sm) - in - ((x, t), sm) - end) - sm xts - val (e, sm) = cifyExp (e, sm) + + val (d, sm) = case #1 t of + L'.TFun (dom, ran) => + (case #1 e of + L.EAbs (ax, _, _, e) => + let + val (e, sm) = cifyExp (e, sm) + in + (L'.DFun (x, n, ax, dom, ran, e), sm) + end + | _ => (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; + (L'.DVal ("", 0, t, (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)), sm))) + | _ => + let + val (e, sm) = cifyExp (e, sm) + in + (L'.DVal (x, n, t, e), sm) + end in - (NONE, SOME (xts, e), sm) + (SOME (d, loc), NONE, sm) end + | L.DExport n => (NONE, SOME n, sm) fun cjrize ds = let diff --git a/src/cloconv.sig b/src/cloconv.sig deleted file mode 100644 index d71d3201..00000000 --- a/src/cloconv.sig +++ /dev/null @@ -1,32 +0,0 @@ -(* 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 CLOCONV = sig - - val cloconv : Mono.file -> Flat.file - -end diff --git a/src/cloconv.sml b/src/cloconv.sml deleted file mode 100644 index b5ea56ca..00000000 --- a/src/cloconv.sml +++ /dev/null @@ -1,239 +0,0 @@ -(* 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 Cloconv :> CLOCONV = struct - -structure L = Mono -structure L' = Flat - -structure IS = IntBinarySet - -structure U = FlatUtil -structure E = FlatEnv - -open Print.PD -open Print - -val liftExpInExp = - U.Exp.mapB {typ = fn t => t, - exp = fn bound => fn e => - case e of - L'.ERel xn => - if xn < bound then - e - else - L'.ERel (xn + 1) - | _ => e, - bind = fn (bound, U.Exp.RelE _) => bound + 1 - | (bound, _) => bound} -val subExpInExp = - U.Exp.mapB {typ = fn t => t, - exp = fn (xn, rep) => fn e => - case e of - L'.ERel xn' => - (case Int.compare (xn', xn) of - EQUAL => #1 rep - | GREATER => L'.ERel (xn' - 1) - | _ => e) - | _ => e, - bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) - | (ctx, _) => ctx} - - -fun ccTyp (t, loc) = - case t of - L.TFun (t1, t2) => (L'.TFun (ccTyp t1, ccTyp t2), loc) - | L.TRecord xts => (L'.TRecord (map (fn (x, t) => (x, ccTyp t)) xts), loc) - | L.TNamed n => (L'.TNamed n, loc) - | L.TFfi mx => (L'.TFfi mx, loc) - -structure Ds :> sig - type t - - val empty : t - - val exp : t -> string * int * L'.typ * L'.exp -> t - val func : t -> string * L'.typ * L'.typ * L'.exp -> t * int - val page : t -> (string * L'.typ) list * L'.exp -> t - val decls : t -> L'.decl list - - val enter : t -> t - val used : t * int -> t - val leave : t -> t - val listUsed : t -> int list -end = struct - -type t = int * L'.decl list * IS.set - -val empty = (0, [], IS.empty) - -fun exp (fc, ds, vm) (v as (_, _, _, (_, loc))) = (fc, (L'.DVal v, loc) :: ds, vm) - -fun func (fc, ds, vm) (x, dom, ran, e as (_, loc)) = - ((fc+1, (L'.DFun (fc, x, dom, ran, e), loc) :: ds, vm), fc) - -fun page (fc, ds, vm) (xts, e as (_, loc)) = (fc, (L'.DPage (xts, e), loc) :: ds, vm) - -fun decls (_, ds, _) = rev ds - -fun enter (fc, ds, vm) = (fc, ds, IS.map (fn n => n + 1) vm) -fun used ((fc, ds, vm), n) = (fc, ds, IS.add (vm, n)) -fun leave (fc, ds, vm) = (fc, ds, IS.map (fn n => n - 1) (IS.delete (vm, 0) handle NotFound => vm)) - -fun listUsed (_, _, vm) = IS.listItems vm - -end - - -fun ccExp env ((e, loc), D) = - case e of - L.EPrim p => ((L'.EPrim p, loc), D) - | L.ERel n => ((L'.ERel n, loc), Ds.used (D, n)) - | L.ENamed n => ((L'.ENamed n, loc), D) - | L.EFfi mx => ((L'.EFfi mx, loc), D) - | L.EFfiApp (m, x, es) => - let - val (es, D) = ListUtil.foldlMap (ccExp env) D es - in - ((L'.EFfiApp (m, x, es), loc), D) - end - | L.EApp (e1, e2) => - let - val (e1, D) = ccExp env (e1, D) - val (e2, D) = ccExp env (e2, D) - in - ((L'.ELet ([("closure", (L'.TTop, loc), e1), - ("arg", (L'.TTop, loc), liftExpInExp 0 e2), - ("code", (L'.TTop, loc), (L'.EField ((L'.ERel 1, loc), "func"), loc)), - ("env", (L'.TTop, loc), (L'.EField ((L'.ERel 2, loc), "env"), loc))], - (L'.EApp ((L'.ERel 1, loc), - (L'.ERecord [("env", (L'.ERel 0, loc), (L'.TTop, loc)), - ("arg", (L'.ERel 2, loc), (L'.TTop, loc))], loc)), loc)), loc), D) - end - | L.EAbs (x, dom, ran, e) => - let - val dom = ccTyp dom - val ran = ccTyp ran - val (e, D) = ccExp (E.pushERel env x dom) (e, Ds.enter D) - val ns = Ds.listUsed D - val ns = List.filter (fn n => n <> 0) ns - val D = Ds.leave D - - val envT = (L'.TRecord (map (fn n => ("fv" ^ Int.toString n, #2 (E.lookupERel env (n-1)))) ns), loc) - - (*val () = Print.preface ("Before", FlatPrint.p_exp FlatEnv.basis e) - val () = List.app (fn (x, t) => preface ("Bound", box [string x, - space, - string ":", - space, - FlatPrint.p_typ env t])) - (E.listERels env) - val () = List.app (fn n => preface ("Free", FlatPrint.p_exp (E.pushERel env x dom) - (L'.ERel n, loc))) ns*) - val body = foldl (fn (n, e) => - subExpInExp (n, (L'.EField ((L'.ERel 1, loc), "fv" ^ Int.toString n), loc)) e) - e ns - (*val () = Print.preface (" After", FlatPrint.p_exp FlatEnv.basis body)*) - val body = (L'.ELet ([("env", envT, (L'.EField ((L'.ERel 0, loc), "env"), loc)), - ("arg", dom, (L'.EField ((L'.ERel 1, loc), "arg"), loc))], - body), loc) - - val (D, fi) = Ds.func D (x, (L'.TRecord [("env", envT), ("arg", dom)], loc), ran, body) - in - ((L'.ERecord [("code", (L'.ECode fi, loc), (L'.TTop, loc)), - ("env", (L'.ERecord (map (fn n => ("fv" ^ Int.toString n, - (L'.ERel (n-1), loc), - #2 (E.lookupERel env (n-1)))) ns), loc), - envT)], loc), D) - end - - | L.ERecord xes => - let - val (xes, D) = ListUtil.foldlMap (fn ((x, e, t), D) => - let - val (e, D) = ccExp env (e, D) - in - ((x, e, ccTyp t), D) - end) D xes - in - ((L'.ERecord xes, loc), D) - end - | L.EField (e1, x) => - let - val (e1, D) = ccExp env (e1, D) - in - ((L'.EField (e1, x), loc), D) - end - - | L.EStrcat (e1, e2) => - let - val (e1, D) = ccExp env (e1, D) - val (e2, D) = ccExp env (e2, D) - in - ((L'.EStrcat (e1, e2), loc), D) - end - - | L.EWrite e => - let - val (e, D) = ccExp env (e, D) - in - ((L'.EWrite e, loc), D) - end - - | L.ESeq (e1, e2) => - let - val (e1, D) = ccExp env (e1, D) - val (e2, D) = ccExp env (e2, D) - in - ((L'.ESeq (e1, e2), loc), D) - end - -fun ccDecl ((d, loc), D) = - case d of - L.DVal (x, n, t, e) => - let - val t = ccTyp t - val (e, D) = ccExp E.empty (e, D) - in - Ds.exp D (x, n, t, e) - end - | L.DPage (xts, e) => - let - val xts = map (fn (x, t) => (x, ccTyp t)) xts - val (e, D) = ccExp E.empty (e, D) - in - Ds.page D (xts, e) - end - -fun cloconv ds = - let - val D = foldl ccDecl Ds.empty ds - in - Ds.decls D - end - -end diff --git a/src/compiler.sig b/src/compiler.sig index c85eba39..62d38308 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -47,7 +47,6 @@ signature COMPILER = sig val shake : job -> Core.file option val monoize : job -> Mono.file option val mono_opt : job -> Mono.file option - val cloconv : job -> Flat.file option val cjrize : job -> Cjr.file option val testParse : job -> unit @@ -59,7 +58,6 @@ signature COMPILER = sig val testShake : job -> unit val testMonoize : job -> unit val testMono_opt : job -> unit - val testCloconv : job -> unit val testCjrize : job -> unit end diff --git a/src/compiler.sml b/src/compiler.sml index 1e40cb11..1f063633 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -111,9 +111,11 @@ fun capitalize "" = "" fun parse fnames = let + fun nameOf fname = capitalize (OS.Path.file fname) + fun parseOne fname = let - val mname = capitalize (OS.Path.file fname) + val mname = nameOf fname val lac = OS.Path.joinBaseExt {base = fname, ext = SOME "lac"} val lig = OS.Path.joinBaseExt {base = fname, ext = SOME "lig"} @@ -137,7 +139,13 @@ fun parse fnames = SOME (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) end - val ds = List.mapPartial parseOne fnames + val ds = List.mapPartial parseOne fnames + val ds = + let + val final = nameOf (List.last fnames) + in + ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)] + end handle Empty => ds in if ErrorMsg.anyErrors () then NONE @@ -224,17 +232,8 @@ fun mono_opt job = else SOME (MonoOpt.optimize file) -fun cloconv job = - case mono_opt job of - NONE => NONE - | SOME file => - if ErrorMsg.anyErrors () then - NONE - else - SOME (Cloconv.cloconv file) - fun cjrize job = - case cloconv job of + case mono_opt job of NONE => NONE | SOME file => if ErrorMsg.anyErrors () then @@ -322,15 +321,6 @@ fun testMono_opt job = handle MonoEnv.UnboundNamed n => print ("Unbound named " ^ Int.toString n ^ "\n") -fun testCloconv job = - (case cloconv job of - NONE => print "Failed\n" - | SOME file => - (Print.print (FlatPrint.p_file FlatEnv.empty file); - print "\n")) - handle FlatEnv.UnboundNamed n => - print ("Unbound named " ^ Int.toString n ^ "\n") - fun testCjrize job = (case cjrize job of NONE => print "Failed\n" diff --git a/src/core.sml b/src/core.sml index 4572a8d9..fe969d18 100644 --- a/src/core.sml +++ b/src/core.sml @@ -80,8 +80,8 @@ withtype exp = exp' located datatype decl' = DCon of string * int * kind * con - | DVal of string * int * con * exp - | DPage of con * exp + | DVal of string * int * con * exp * string + | DExport of int withtype decl = decl' located diff --git a/src/core_env.sig b/src/core_env.sig index 56945972..59087ace 100644 --- a/src/core_env.sig +++ b/src/core_env.sig @@ -45,8 +45,8 @@ signature CORE_ENV = sig val pushERel : env -> string -> Core.con -> env val lookupERel : env -> int -> string * Core.con - val pushENamed : env -> string -> int -> Core.con -> Core.exp option -> env - val lookupENamed : env -> int -> string * Core.con * Core.exp option + val pushENamed : env -> string -> int -> Core.con -> Core.exp option -> string -> env + val lookupENamed : env -> int -> string * Core.con * Core.exp option * string val declBinds : env -> Core.decl -> env diff --git a/src/core_env.sml b/src/core_env.sml index 2b6de82c..5a24a82a 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -62,7 +62,7 @@ type env = { namedC : (string * kind * con option) IM.map, relE : (string * con) list, - namedE : (string * con * exp option) IM.map + namedE : (string * con * exp option * string) IM.map } val empty = { @@ -78,7 +78,7 @@ fun pushCRel (env : env) x k = namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env), relE = map (fn (x, c) => (x, lift c)) (#relE env), - namedE = IM.map (fn (x, c, eo) => (x, lift c, eo)) (#namedE env)} + namedE = IM.map (fn (x, c, eo, s) => (x, lift c, eo, s)) (#namedE env)} fun lookupCRel (env : env) n = (List.nth (#relC env, n)) @@ -107,12 +107,12 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n -fun pushENamed (env : env) x n t eo = +fun pushENamed (env : env) x n t eo s = {relC = #relC env, namedC = #namedC env, relE = #relE env, - namedE = IM.insert (#namedE env, n, (x, t, eo))} + namedE = IM.insert (#namedE env, n, (x, t, eo, s))} fun lookupENamed (env : env) n = case IM.find (#namedE env, n) of @@ -122,7 +122,7 @@ fun lookupENamed (env : env) n = fun declBinds env (d, _) = case d of DCon (x, n, k, c) => pushCNamed env x n k (SOME c) - | DVal (x, n, t, e) => pushENamed env x n t (SOME e) - | DPage _ => env + | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s + | DExport _ => env end diff --git a/src/core_print.sml b/src/core_print.sml index be2f7387..b1cc9c2d 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -145,6 +145,13 @@ and p_name env (all as (c, _)) = CName s => string s | _ => p_con env all +fun p_enamed env n = + (if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n) + fun p_exp' par env (e, _) = case e of EPrim p => Prim.p_t p @@ -154,12 +161,7 @@ fun p_exp' par env (e, _) = else string (#1 (E.lookupERel env n))) handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n)) - | ENamed n => - ((if !debug then - string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) - else - string (#1 (E.lookupENamed env n))) - handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) + | ENamed n => p_enamed env n | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] | EFfiApp (m, x, es) => box [string "FFI(", string m, @@ -255,7 +257,7 @@ fun p_decl env ((d, _) : decl) = space, p_con env c] end - | DVal (x, n, t, e) => + | DVal (x, n, t, e, s) => let val xp = if !debug then box [string x, @@ -268,6 +270,10 @@ fun p_decl env ((d, _) : decl) = space, xp, space, + string "as", + space, + string s, + space, string ":", space, p_con env t, @@ -276,12 +282,9 @@ fun p_decl env ((d, _) : decl) = space, p_exp env e] end - | DPage (c, e) => box [string "page", - p_con env c, - space, - string "=", - space, - p_exp env e] + | DExport n => box [string "export", + space, + p_enamed env n] fun p_file env file = let diff --git a/src/core_util.sig b/src/core_util.sig index 64cd671b..423b93b4 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -69,7 +69,7 @@ structure Exp : sig RelC of string * Core.kind | NamedC of string * int * Core.kind * Core.con option | RelE of string * Core.con - | NamedE of string * int * Core.con * Core.exp option + | NamedE of string * int * Core.con * Core.exp option * string val mapfoldB : {kind : (Core.kind', 'state, 'abort) Search.mapfolder, con : ('context, Core.con', 'state, 'abort) Search.mapfolderB, diff --git a/src/core_util.sml b/src/core_util.sml index df20ef9a..11d70de9 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -203,7 +203,7 @@ datatype binder = RelC of string * kind | NamedC of string * int * kind * con option | RelE of string * con - | NamedE of string * int * con * exp option + | NamedE of string * int * con * exp option * string fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let @@ -375,18 +375,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = S.map2 (mfc ctx c, fn c' => (DCon (x, n, k', c'), loc))) - | DVal (x, n, t, e) => + | DVal (x, n, t, e, s) => S.bind2 (mfc ctx t, fn t' => S.map2 (mfe ctx e, fn e' => - (DVal (x, n, t', e'), loc))) - | DPage (c, e) => - S.bind2 (mfc ctx c, - fn c' => - S.map2 (mfe ctx e, - fn e' => - (DPage (c', e'), loc))) + (DVal (x, n, t', e', s), loc))) + | DExport _ => S.return2 dAll in mfd end @@ -426,8 +421,8 @@ fun mapfoldB (all as {bind, ...}) = val ctx' = case #1 d' of DCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c)) - | DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e)) - | DPage _ => ctx + | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s)) + | DExport _ => ctx in S.map2 (mff ctx' ds', fn ds' => diff --git a/src/corify.sml b/src/corify.sml index 43acedfc..faeda0d1 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -362,6 +362,7 @@ fun corifyExp st (e, loc) = | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, {field = corifyCon st field, rest = corifyCon st rest}), loc) | L.EFold k => (L'.EFold (corifyKind k), loc) + | L.EWrite e => (L'.EWrite (corifyExp st e), loc) fun corifyDecl ((d, loc : EM.span), st) = case d of @@ -375,7 +376,7 @@ fun corifyDecl ((d, loc : EM.span), st) = let val (st, n) = St.bindVal st x n in - ([(L'.DVal (x, n, corifyCon st t, corifyExp st e), loc)], st) + ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, x), loc)], st) end | L.DSgn _ => ([], st) @@ -427,19 +428,60 @@ fun corifyDecl ((d, loc : EM.span), st) = end | _ => raise Fail "Non-const signature for FFI structure") - | L.DPage (c, e) => - let - val c = corifyCon st c - val e = corifyExp st e - - val dom = (L'.TRecord c, loc) - val ran = (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc) - val e = (L'.EAbs ("vs", dom, ran, - (L'.EWrite (L'.EApp (e, (L'.ERel 0, loc)), loc), loc)), loc) - - in - ([(L'.DPage (c, e), loc)], st) - end + | L.DExport (en, sgn, str) => + (case #1 sgn of + L.SgnConst sgis => + let + fun pathify (str, _) = + case str of + L.StrVar m => SOME (m, []) + | L.StrProj (str, s) => + Option.map (fn (m, ms) => (m, ms @ [s])) (pathify str) + | _ => NONE + in + case pathify str of + NONE => (ErrorMsg.errorAt loc "Structure is too fancy to export"; + ([], st)) + | SOME (m, ms) => + let + fun wrapSgi ((sgi, _), (wds, eds)) = + case sgi of + L.SgiVal (s, _, t as (L.TFun (dom, ran), _)) => + (case (#1 dom, #1 ran) of + (L.TRecord _, + L.CApp ((L.CModProj (_, [], "xml"), _), + (L.TRecord (L.CRecord (_, [((L.CName "Html", _), + _)]), _), _))) => + let + val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) + val e = (L.EModProj (m, ms, s), loc) + val e = (L.EAbs ("vs", dom, ran, + (L.EWrite (L.EApp (e, (L.ERel 0, loc)), loc), loc)), loc) + in + ((L.DVal ("wrap_" ^ s, 0, + (L.TFun (dom, ran), loc), + e), loc) :: wds, + (fn st => + case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of + L'.ENamed n => (L'.DExport n, loc) + | _ => raise Fail "Corify: Value to export didn't corify properly") + :: eds) + end + | _ => (wds, eds)) + | _ => (wds, eds) + + val (wds, eds) = foldl wrapSgi ([], []) sgis + val wrapper = (L.StrConst wds, loc) + val (ds, {inner, outer}) = corifyStr (wrapper, st) + val st = St.bindStr outer "wrapper" en inner + + val ds = ds @ map (fn f => f st) eds + in + (ds, st) + end + end + | _ => raise Fail "Non-const signature for 'export'") + and corifyStr ((str, _), st) = case str of @@ -487,7 +529,7 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DSgn (_, n', _) => Int.max (n, n') | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)) | L.DFfiStr (_, n', _) => Int.max (n, n') - | L.DPage _ => n) + | L.DExport _ => n) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 9fca4e13..d9d59d98 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -115,7 +115,7 @@ datatype decl' = | DStr of string * int * sgn * str | DFfiStr of string * int * sgn | DConstraint of con * con - | DPage of con * exp + | DExport of int * sgn * str and str' = StrConst of decl list diff --git a/src/elab_env.sig b/src/elab_env.sig index 0e43c9a7..83490b69 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -83,4 +83,6 @@ signature ELAB_ENV = sig val projectStr : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.sgn option val projectConstraints : env -> { sgn : Elab.sgn, str : Elab.str } -> (Elab.con * Elab.con) list option + val newNamed : unit -> int + end diff --git a/src/elab_env.sml b/src/elab_env.sml index be49d06f..b0550299 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -91,6 +91,14 @@ type env = { val namedCounter = ref 0 +fun newNamed () = + let + val r = !namedCounter + in + namedCounter := r + 1; + r + end + val empty = { renameC = SM.empty, relC = [], @@ -292,7 +300,7 @@ fun declBinds env (d, _) = | DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn | DConstraint _ => env - | DPage _ => env + | DExport _ => env fun sgiBinds env (sgi, _) = case sgi of diff --git a/src/elab_print.sml b/src/elab_print.sml index 51ff6a95..8d676f4a 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -450,12 +450,12 @@ fun p_decl env ((d, _) : decl) = string "~", space, p_con env c2] - | DPage (c, e) => box [string "page", - p_con env c, - space, - string "=", - space, - p_exp env e] + | DExport (_, sgn, str) => box [string "export", + p_str env str, + space, + string ":", + space, + p_sgn env sgn] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 293e53ac..c14b2c60 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -511,7 +511,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DFfiStr (x, _, sgn) => bind (ctx, Str (x, sgn)) | DConstraint _ => ctx - | DPage _ => ctx, + | DExport _ => ctx, mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -572,12 +572,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f S.map2 (mfc ctx c2, fn c2' => (DConstraint (c1', c2'), loc))) - | DPage (c, e) => - S.bind2 (mfc ctx c, - fn c' => - S.map2 (mfe ctx e, - fn e' => - (DPage (c', e'), loc))) + | DExport (en, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DExport (en, sgn', str'), loc))) in mfd end diff --git a/src/elaborate.sml b/src/elaborate.sml index faa19ec4..81b3e8c4 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1599,7 +1599,7 @@ fun sgiOfDecl (d, loc) = | L'.DStr (x, n, sgn, _) => SOME (L'.SgiStr (x, n, sgn), loc) | L'.DFfiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, sgn), loc) | L'.DConstraint cs => SOME (L'.SgiConstraint cs, loc) - | L'.DPage _ => NONE + | L'.DExport _ => NONE fun sgiBindsD (env, denv) (sgi, _) = case sgi of @@ -1929,27 +1929,41 @@ fun elabDecl ((d, loc), (env, denv, gs)) = ([], (env, denv, [])) end - | L.DPage e => + | L.DExport str => let - val basis = - case E.lookupStr env "Basis" of - NONE => raise Fail "elabExp: Unbound Basis" - | SOME (n, _) => n - - val (e', t, gs1) = elabExp (env, denv) e - - val k = (L'.KRecord (L'.KType, loc), loc) - val vs = cunif (loc, k) - - val c = (L'.TFun ((L'.TRecord vs, loc), - (L'.CApp ((L'.CModProj (basis, [], "xml"), loc), - (L'.CRecord ((L'.KUnit, loc), - [((L'.CName "Html", loc), - (L'.CUnit, loc))]), loc)), loc)), loc) + val (str', sgn, gs) = elabStr (env, denv) str - val gs2 = checkCon (env, denv) e' t c + val sgn = + case #1 (hnormSgn env sgn) of + L'.SgnConst sgis => + let + fun doOne (all as (sgi, _)) = + case sgi of + L'.SgiVal (x, n, t) => + (case hnormCon (env, denv) t of + ((L'.TFun (dom, ran), _), []) => + (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of + (((L'.TRecord domR, _), []), + ((L'.CApp (tf, ranR), _), [])) => + (case hnormCon (env, denv) ranR of + (ranR, []) => + (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of + ((domR, []), (ranR, [])) => + (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc), + (L'.CApp (tf, + (L'.TRecord ranR, loc)), loc)), + loc)), loc) + | _ => all) + | _ => all) + | _ => all) + | _ => all) + | _ => all + in + (L'.SgnConst (map doOne sgis), loc) + end + | _ => sgn in - ([(L'.DPage (vs, e'), loc)], (env, denv, gs1 @ gs2)) + ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs)) end and elabStr (env, denv) (str, loc) = diff --git a/src/expl.sml b/src/expl.sml index bf40a511..d6ceb35b 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -73,6 +73,8 @@ datatype exp' = | EField of exp * con * { field : con, rest : con } | EFold of kind + | EWrite of exp + withtype exp = exp' located datatype sgn_item' = @@ -98,7 +100,7 @@ datatype decl' = | DSgn of string * int * sgn | DStr of string * int * sgn * str | DFfiStr of string * int * sgn - | DPage of con * exp + | DExport of int * sgn * str and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 93d21c31..b9c95605 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -243,7 +243,7 @@ fun declBinds env (d, _) = | DSgn (x, n, sgn) => pushSgnNamed env x n sgn | DStr (x, n, sgn, _) => pushStrNamed env x n sgn | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn - | DPage _ => env + | DExport _ => env fun sgiBinds env (sgi, _) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index c891528f..1e8f514a 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -92,7 +92,8 @@ fun p_con' par env (c, _) = handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | CModProj (m1, ms, x) => let - val (m1x, sgn) = E.lookupStrNamed env m1 + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND" val m1s = if !debug then m1x ^ "__" ^ Int.toString m1 @@ -237,6 +238,10 @@ fun p_exp' par env (e, _) = p_con' true env c] | EFold _ => string "fold" + | EWrite e => box [string "write(", + p_exp env e, + string ")"] + and p_exp env = p_exp' false env fun p_named x n = @@ -392,12 +397,13 @@ fun p_decl env ((d, _) : decl) = string ":", space, p_sgn env sgn] - | DPage (c, e) => box [string "page", - p_con env c, - space, - string "=", - space, - p_exp env e] + | DExport (_, sgn, str) => box [string "export", + space, + p_str env str, + space, + string ":", + space, + p_sgn env sgn] and p_str env (str, _) = case str of diff --git a/src/expl_util.sml b/src/expl_util.sml index 57498fde..c4f1b1d7 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -271,6 +271,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfk k, fn k' => (EFold k', loc)) + + | EWrite e => + S.map2 (mfe ctx e, + fn e' => + (EWrite e', loc)) in mfe end diff --git a/src/explify.sml b/src/explify.sml index 8c6cc9f5..ecca21f8 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -116,7 +116,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DStr (x, n, sgn, str) => SOME (L'.DStr (x, n, explifySgn sgn, explifyStr str), loc) | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc) | L.DConstraint (c1, c2) => NONE - | L.DPage (c, e) => SOME (L'.DPage (explifyCon c, explifyExp e), loc) + | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) and explifyStr (str, loc) = case str of diff --git a/src/flat.sml b/src/flat.sml deleted file mode 100644 index 2b63bc24..00000000 --- a/src/flat.sml +++ /dev/null @@ -1,72 +0,0 @@ -(* 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 Flat = struct - -type 'a located = 'a ErrorMsg.located - -datatype typ' = - TTop - | TFun of typ * typ - | TCode of typ * typ - | TRecord of (string * typ) list - | TNamed of int - | TFfi of string * string - -withtype typ = typ' located - -datatype exp' = - EPrim of Prim.t - | ERel of int - | ENamed of int - | EFfi of string * string - | EFfiApp of string * string * exp list - | ECode of int - | EApp of exp * exp - - | ERecord of (string * exp * typ) list - | EField of exp * string - - | ELet of (string * typ * exp) list * exp - - | EStrcat of exp * exp - - | EWrite of exp - | ESeq of exp * exp - -withtype exp = exp' located - -datatype decl' = - DVal of string * int * typ * exp - | DFun of int * string * typ * typ * exp - | DPage of (string * typ) list * exp - -withtype decl = decl' located - -type file = decl list - -end diff --git a/src/flat_env.sig b/src/flat_env.sig deleted file mode 100644 index 9fc1fc57..00000000 --- a/src/flat_env.sig +++ /dev/null @@ -1,53 +0,0 @@ -(* 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 FLAT_ENV = sig - - type env - - val empty : env - - exception UnboundRel of int - exception UnboundNamed of int - exception UnboundF of int - - val pushTNamed : env -> string -> int -> Flat.typ option -> env - val lookupTNamed : env -> int -> string * Flat.typ option - - val pushERel : env -> string -> Flat.typ -> env - val lookupERel : env -> int -> string * Flat.typ - val listERels : env -> (string * Flat.typ) list - - val pushENamed : env -> string -> int -> Flat.typ -> env - val lookupENamed : env -> int -> string * Flat.typ - - val pushF : env -> int -> string -> Flat.typ -> Flat.typ -> env - val lookupF : env -> int -> string * Flat.typ * Flat.typ - - val declBinds : env -> Flat.decl -> env - -end diff --git a/src/flat_env.sml b/src/flat_env.sml deleted file mode 100644 index d86b6c97..00000000 --- a/src/flat_env.sml +++ /dev/null @@ -1,116 +0,0 @@ -(* 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 FlatEnv :> FLAT_ENV = struct - -open Flat - -structure IM = IntBinaryMap - - -exception UnboundRel of int -exception UnboundNamed of int -exception UnboundF of int - -type env = { - namedT : (string * typ option) IM.map, - - relE : (string * typ) list, - namedE : (string * typ) IM.map, - - F : (string * typ * typ) IM.map -} - -val empty = { - namedT = IM.empty, - - relE = [], - namedE = IM.empty, - - F = IM.empty -} - -fun pushTNamed (env : env) x n co = - {namedT = IM.insert (#namedT env, n, (x, co)), - - relE = #relE env, - namedE = #namedE env, - - F = #F 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, - - F = #F env} - -fun lookupERel (env : env) n = - (List.nth (#relE env, n)) - handle Subscript => raise UnboundRel n - -fun listERels (env : env) = #relE env - -fun pushENamed (env : env) x n t = - {namedT = #namedT env, - - relE = #relE env, - namedE = IM.insert (#namedE env, n, (x, t)), - - F = #F env} - -fun lookupENamed (env : env) n = - case IM.find (#namedE env, n) of - NONE => raise UnboundNamed n - | SOME x => x - -fun pushF (env : env) n x dom ran = - {namedT = #namedT env, - - relE = #relE env, - namedE = #namedE env, - - F = IM.insert (#F env, n, (x, dom, ran))} - -fun lookupF (env : env) n = - case IM.find (#F env, n) of - NONE => raise UnboundF n - | SOME x => x - -fun declBinds env (d, _) = - case d of - DVal (x, n, t, _) => pushENamed env x n t - | DFun (n, x, dom, ran, _) => pushF env n x dom ran - | DPage _ => env - -end diff --git a/src/flat_print.sig b/src/flat_print.sig deleted file mode 100644 index 627bfee9..00000000 --- a/src/flat_print.sig +++ /dev/null @@ -1,37 +0,0 @@ -(* 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 flat-code language *) - -signature FLAT_PRINT = sig - val p_typ : FlatEnv.env -> Flat.typ Print.printer - val p_exp : FlatEnv.env -> Flat.exp Print.printer - val p_decl : FlatEnv.env -> Flat.decl Print.printer - val p_file : FlatEnv.env -> Flat.file Print.printer - - val debug : bool ref -end diff --git a/src/flat_print.sml b/src/flat_print.sml deleted file mode 100644 index f94614b4..00000000 --- a/src/flat_print.sml +++ /dev/null @@ -1,236 +0,0 @@ -(* 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 flat-code Laconic/Web *) - -structure FlatPrint :> FLAT_PRINT = struct - -open Print.PD -open Print - -open Flat - -structure E = FlatEnv - -val debug = ref false - -val dummyTyp = (TNamed 0, ErrorMsg.dummySpan) - -fun p_typ' par env (t, _) = - case t of - TTop => string "?" - | TFun (t1, t2) => parenIf par (box [p_typ' true env t1, - space, - string "->", - space, - p_typ env t2]) - | TCode (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)) - | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] - -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))) - handle E.UnboundRel _ => string ("UNBOUND" ^ Int.toString n)) - | ENamed n => - if !debug then - string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) - else - string (#1 (E.lookupENamed env n)) - | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] - | EFfiApp (m, x, es) => box [string "FFI(", - string m, - string ".", - string x, - string "(", - p_list (p_exp env) es, - string "))"] - | ECode n => string ("code$" ^ Int.toString n) - | EApp (e1, e2) => parenIf par (box [p_exp env e1, - space, - p_exp' true env e2]) - - | 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] - - | ELet (xes, e) => - let - val (env, pps) = foldl (fn ((x, _, e), (env, pps)) => - (E.pushERel env x dummyTyp, - List.revAppend ([space, - string "val", - space, - string x, - space, - string "=", - space, - p_exp env e], - pps))) - (env, []) xes - in - box [string "let", - space, - box (rev pps), - space, - string "in", - space, - p_exp env e, - space, - string "end"] - end - - | EStrcat (e1, e2) => box [p_exp' true env e1, - space, - string "^", - space, - p_exp' true env e2] - - | EWrite e => box [string "write(", - p_exp env e, - string ")"] - - | ESeq (e1, e2) => box [p_exp env e1, - string ";", - space, - p_exp env e2] - -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 - | DFun (n, x, dom, ran, e) => - let - val xp = if !debug then - box [string x, - string "__", - string (Int.toString n)] - else - string x - in - box [string "fun", - space, - string "code$", - string (Int.toString n), - space, - string "(", - xp, - space, - string ":", - space, - p_typ env dom, - string ")", - space, - string ":", - space, - p_typ env ran, - space, - string "=", - space, - p_exp (E.pushERel env x dom) e] - - end - - | DPage (xcs, e) => box [string "page", - string "[", - p_list (fn (x, t) => - box [string x, - space, - string ":", - space, - p_typ env t]) xcs, - string "]", - space, - string "=", - space, - p_exp env e] - -fun p_file env file = - let - val (pds, _) = ListUtil.foldlMap (fn (d, env) => - (p_decl env d, - E.declBinds env d)) - env file - in - p_list_sep newline (fn x => x) pds - end - -end diff --git a/src/flat_util.sig b/src/flat_util.sig deleted file mode 100644 index ff7edcd1..00000000 --- a/src/flat_util.sig +++ /dev/null @@ -1,125 +0,0 @@ -(* 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 FLAT_UTIL = sig - -structure Typ : sig - val compare : Flat.typ * Flat.typ -> order - val sortFields : (string * Flat.typ) list -> (string * Flat.typ) list - - val mapfold : (Flat.typ', 'state, 'abort) Search.mapfolder - -> (Flat.typ, 'state, 'abort) Search.mapfolder - - val map : (Flat.typ' -> Flat.typ') - -> Flat.typ -> Flat.typ - - val fold : (Flat.typ' * 'state -> 'state) - -> 'state -> Flat.typ -> 'state - - val exists : (Flat.typ' -> bool) -> Flat.typ -> bool -end - -structure Exp : sig - datatype binder = - NamedT of string * int * Flat.typ option - | RelE of string * Flat.typ - | NamedE of string * int * Flat.typ * Flat.exp option - - val mapfoldB : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder, - exp : ('typtext, Flat.exp', 'state, 'abort) Search.mapfolderB, - bind : 'typtext * binder -> 'typtext} - -> ('typtext, Flat.exp, 'state, 'abort) Search.mapfolderB - val mapfold : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder, - exp : (Flat.exp', 'state, 'abort) Search.mapfolder} - -> (Flat.exp, 'state, 'abort) Search.mapfolder - - val map : {typ : Flat.typ' -> Flat.typ', - exp : Flat.exp' -> Flat.exp'} - -> Flat.exp -> Flat.exp - val mapB : {typ : Flat.typ' -> Flat.typ', - exp : 'typtext -> Flat.exp' -> Flat.exp', - bind : 'typtext * binder -> 'typtext} - -> 'typtext -> (Flat.exp -> Flat.exp) - - val fold : {typ : Flat.typ' * 'state -> 'state, - exp : Flat.exp' * 'state -> 'state} - -> 'state -> Flat.exp -> 'state - - val exists : {typ : Flat.typ' -> bool, - exp : Flat.exp' -> bool} -> Flat.exp -> bool -end - -structure Decl : sig - datatype binder = datatype Exp.binder - - val mapfoldB : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder, - exp : ('typtext, Flat.exp', 'state, 'abort) Search.mapfolderB, - decl : ('typtext, Flat.decl', 'state, 'abort) Search.mapfolderB, - bind : 'typtext * binder -> 'typtext} - -> ('typtext, Flat.decl, 'state, 'abort) Search.mapfolderB - val mapfold : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder, - exp : (Flat.exp', 'state, 'abort) Search.mapfolder, - decl : (Flat.decl', 'state, 'abort) Search.mapfolder} - -> (Flat.decl, 'state, 'abort) Search.mapfolder - - val fold : {typ : Flat.typ' * 'state -> 'state, - exp : Flat.exp' * 'state -> 'state, - decl : Flat.decl' * 'state -> 'state} - -> 'state -> Flat.decl -> 'state -end - -structure File : sig - datatype binder = - NamedT of string * int * Flat.typ option - | RelE of string * Flat.typ - | NamedE of string * int * Flat.typ * Flat.exp option - | F of int * string * Flat.typ * Flat.typ * Flat.exp - - val mapfoldB : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder, - exp : ('typtext, Flat.exp', 'state, 'abort) Search.mapfolderB, - decl : ('typtext, Flat.decl', 'state, 'abort) Search.mapfolderB, - bind : 'typtext * binder -> 'typtext} - -> ('typtext, Flat.file, 'state, 'abort) Search.mapfolderB - - val mapfold : {typ : (Flat.typ', 'state, 'abort) Search.mapfolder, - exp : (Flat.exp', 'state, 'abort) Search.mapfolder, - decl : (Flat.decl', 'state, 'abort) Search.mapfolder} - -> (Flat.file, 'state, 'abort) Search.mapfolder - - val mapB : {typ : Flat.typ' -> Flat.typ', - exp : 'typtext -> Flat.exp' -> Flat.exp', - decl : 'typtext -> Flat.decl' -> Flat.decl', - bind : 'typtext * binder -> 'typtext} - -> 'typtext -> Flat.file -> Flat.file - - val fold : {typ : Flat.typ' * 'state -> 'state, - exp : Flat.exp' * 'state -> 'state, - decl : Flat.decl' * 'state -> 'state} - -> 'state -> Flat.file -> 'state -end - -end diff --git a/src/flat_util.sml b/src/flat_util.sml deleted file mode 100644 index 7e52381d..00000000 --- a/src/flat_util.sml +++ /dev/null @@ -1,376 +0,0 @@ -(* 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 FlatUtil :> FLAT_UTIL = struct - -open Flat - -structure S = Search - -structure Typ = struct - -fun join (o1, o2) = - case o1 of - EQUAL => o2 () - | v => v - -fun joinL f (os1, os2) = - case (os1, os2) of - (nil, nil) => EQUAL - | (nil, _) => LESS - | (h1 :: t1, h2 :: t2) => - join (f (h1, h2), fn () => joinL f (t1, t2)) - | (_ :: _, nil) => GREATER - -fun compare ((t1, _), (t2, _)) = - case (t1, t2) of - (TTop, TTop) => EQUAL - | (TFun (d1, r1), TFun (d2, r2)) => - join (compare (d1, d2), fn () => compare (r1, r2)) - | (TCode (d1, r1), TCode (d2, r2)) => - join (compare (d1, d2), fn () => compare (r1, r2)) - | (TRecord xts1, TRecord xts2) => - let - val xts1 = sortFields xts1 - val xts2 = sortFields xts2 - in - joinL compareFields (xts1, xts2) - end - | (TNamed n1, TNamed n2) => Int.compare (n1, n2) - | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) - - | (TTop, _) => LESS - | (_, TTop) => GREATER - - | (TFun _, _) => LESS - | (_, TFun _) => GREATER - - | (TCode _, _) => LESS - | (_, TCode _) => GREATER - - | (TRecord _, _) => LESS - | (_, TRecord _) => GREATER - - | (TNamed _, _) => LESS - | (_, TNamed _) => GREATER - -and compareFields ((x1, t1), (x2, t2)) = - join (String.compare (x1, x2), - fn () => compare (t1, t2)) - -and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts - -fun mapfold fc = - let - fun mft c acc = - S.bindP (mft' c acc, fc) - - and mft' (cAll as (c, loc)) = - case c of - TTop => S.return2 cAll - | TFun (t1, t2) => - S.bind2 (mft t1, - fn t1' => - S.map2 (mft t2, - fn t2' => - (TFun (t1', t2'), loc))) - | TCode (t1, t2) => - S.bind2 (mft t1, - fn t1' => - S.map2 (mft t2, - fn t2' => - (TCode (t1', t2'), loc))) - | TRecord xts => - S.map2 (ListUtil.mapfold (fn (x, t) => - S.map2 (mft t, - fn t' => - (x, t'))) - xts, - fn xts' => (TRecord xts', loc)) - | TNamed _ => S.return2 cAll - | TFfi _ => S.return2 cAll - in - mft - end - -fun map typ c = - case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of - S.Return () => raise Fail "Flat_util.Typ.map" - | S.Continue (c, ()) => c - -fun fold typ s c = - case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of - S.Continue (_, s) => s - | S.Return _ => raise Fail "FlatUtil.Typ.fold: Impossible" - -fun exists typ k = - case mapfold (fn c => fn () => - if typ c then - S.Return () - else - S.Continue (c, ())) k () of - S.Return _ => true - | S.Continue _ => false - -end - -structure Exp = struct - -datatype binder = - NamedT of string * int * typ option - | RelE of string * typ - | NamedE of string * int * typ * exp option - -fun mapfoldB {typ = fc, exp = fe, bind} = - let - val mft = Typ.mapfold fc - - fun mfe ctx e acc = - S.bindP (mfe' ctx e acc, fe ctx) - - and mfe' ctx (eAll as (e, loc)) = - case e of - EPrim _ => S.return2 eAll - | ERel _ => S.return2 eAll - | ENamed _ => S.return2 eAll - | EFfi _ => S.return2 eAll - | EFfiApp (m, x, es) => - S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es, - fn es' => - (EFfiApp (m, x, es'), loc)) - | ECode _ => S.return2 eAll - | EApp (e1, e2) => - S.bind2 (mfe ctx e1, - fn e1' => - S.map2 (mfe ctx e2, - fn e2' => - (EApp (e1', e2'), loc))) - - | ERecord xes => - S.map2 (ListUtil.mapfold (fn (x, e, t) => - S.bind2 (mfe ctx e, - fn e' => - S.map2 (mft t, - fn t' => - (x, e', t')))) - xes, - fn xes' => - (ERecord xes', loc)) - | EField (e, x) => - S.map2 (mfe ctx e, - fn e' => - (EField (e', x), loc)) - - | ELet (xes, e) => - S.bind2 (ListUtil.mapfold (fn (x, t, e) => - S.bind2 (mft t, - fn t' => - S.map2 (mfe ctx e, - fn e' => - (x, t', e')))) - xes, - fn xes' => - S.map2 (mfe ctx e, - fn e' => - (ELet (xes', e'), loc))) - - | EStrcat (e1, e2) => - S.bind2 (mfe ctx e1, - fn e1' => - S.map2 (mfe ctx e2, - fn e2' => - (EStrcat (e1', e2'), loc))) - - | EWrite e => - S.map2 (mfe ctx e, - fn e' => - (EWrite e', loc)) - - | ESeq (e1, e2) => - S.bind2 (mfe ctx e1, - fn e1' => - S.map2 (mfe ctx e2, - fn e2' => - (ESeq (e1', e2'), loc))) - in - mfe - end - -fun mapfold {typ = fc, exp = fe} = - mapfoldB {typ = fc, - exp = fn () => fe, - bind = fn ((), _) => ()} () - -fun mapB {typ, exp, bind} ctx e = - case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()), - exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), - bind = bind} ctx e () of - S.Continue (e, ()) => e - | S.Return _ => raise Fail "FlatUtil.Exp.mapB: Impossible" - -fun map {typ, exp} e = - case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), - exp = fn e => fn () => S.Continue (exp e, ())} e () of - S.Return () => raise Fail "Flat_util.Exp.map" - | S.Continue (e, ()) => e - -fun fold {typ, exp} s e = - case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), - exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of - S.Continue (_, s) => s - | S.Return _ => raise Fail "FlatUtil.Exp.fold: Impossible" - -fun exists {typ, exp} k = - case mapfold {typ = fn c => fn () => - if typ c then - S.Return () - else - S.Continue (c, ()), - exp = fn e => fn () => - if exp e then - S.Return () - else - S.Continue (e, ())} k () of - S.Return _ => true - | S.Continue _ => false - -end - -structure Decl = struct - -datatype binder = datatype Exp.binder - -fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = - let - val mft = Typ.mapfold fc - - val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind} - - fun mfd ctx d acc = - S.bindP (mfd' ctx d acc, fd ctx) - - and mfd' ctx (dAll as (d, loc)) = - case d of - DVal (x, n, t, e) => - S.bind2 (mft t, - fn t' => - S.map2 (mfe ctx e, - fn e' => - (DVal (x, n, t', e'), loc))) - | DFun (n, x, dom, ran, e) => - S.bind2 (mft dom, - fn dom' => - S.bind2 (mft ran, - fn ran' => - S.map2 (mfe ctx e, - fn e' => - (DFun (n, x, dom', ran', e'), loc)))) - | DPage (xts, e) => - S.bind2 (ListUtil.mapfold (fn (x, t) => - S.map2 (mft t, - fn t' => - (x, t'))) xts, - fn xts' => - S.map2 (mfe ctx e, - fn e' => - (DPage (xts', e'), loc))) - in - mfd - end - -fun mapfold {typ = fc, exp = fe, decl = fd} = - mapfoldB {typ = fc, - exp = fn () => fe, - decl = fn () => fd, - bind = fn ((), _) => ()} () - -fun fold {typ, exp, decl} s d = - case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), - exp = fn e => fn s => S.Continue (e, exp (e, s)), - decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of - S.Continue (_, s) => s - | S.Return _ => raise Fail "FlatUtil.Decl.fold: Impossible" - -end - -structure File = struct - -datatype binder = - NamedT of string * int * typ option - | RelE of string * typ - | NamedE of string * int * typ * exp option - | F of int * string * Flat.typ * Flat.typ * Flat.exp - -fun mapfoldB (all as {bind, ...}) = - let - val mfd = Decl.mapfoldB all - - fun mff ctx ds = - case ds of - nil => S.return2 nil - | d :: ds' => - S.bind2 (mfd ctx d, - fn d' => - let - val ctx' = - case #1 d' of - DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e)) - | DFun v => bind (ctx, F v) - | DPage _ => ctx - in - S.map2 (mff ctx' ds', - fn ds' => - d' :: ds') - end) - in - mff - end - -fun mapfold {typ = fc, exp = fe, decl = fd} = - mapfoldB {typ = fc, - exp = fn () => fe, - decl = fn () => fd, - bind = fn ((), _) => ()} () - -fun mapB {typ, exp, decl, bind} ctx ds = - case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()), - exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), - decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()), - bind = bind} ctx ds () of - S.Continue (ds, ()) => ds - | S.Return _ => raise Fail "FlatUtil.File.mapB: Impossible" - -fun fold {typ, exp, decl} s d = - case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), - exp = fn e => fn s => S.Continue (e, exp (e, s)), - decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of - S.Continue (_, s) => s - | S.Return _ => raise Fail "FlatUtil.File.fold: Impossible" - -end - -end diff --git a/src/lacweb.grm b/src/lacweb.grm index 6e71721f..914f3551 100644 --- a/src/lacweb.grm +++ b/src/lacweb.grm @@ -49,7 +49,7 @@ fun uppercaseFirst "" = "" | ARROW | LARROW | DARROW | FN | PLUSPLUS | DOLLAR | TWIDDLE | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN - | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | PAGE + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | XML_BEGIN of string | XML_END | NOTAGS of string @@ -147,7 +147,7 @@ decl : CON SYMBOL EQ cexp (DCon (SYMBOL, NONE, cexp), s (CONleft, [] => raise Fail "Impossible mpath parse [3]" | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright))) | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) - | PAGE eexp (DPage eexp, s (PAGEleft, eexpright)) + | EXPORT spath (DExport spath, s (EXPORTleft, spathright)) sgn : sgntm (sgntm) | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn diff --git a/src/lacweb.lex b/src/lacweb.lex index 4856bdf2..41163a61 100644 --- a/src/lacweb.lex +++ b/src/lacweb.lex @@ -264,7 +264,7 @@ notags = [^<{\n]+; <INITIAL> "open" => (Tokens.OPEN (pos yypos, pos yypos + size yytext)); <INITIAL> "constraint"=> (Tokens.CONSTRAINT (pos yypos, pos yypos + size yytext)); <INITIAL> "constraints"=> (Tokens.CONSTRAINTS (pos yypos, pos yypos + size yytext)); -<INITIAL> "page" => (Tokens.PAGE (pos yypos, pos yypos + size yytext)); +<INITIAL> "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); <INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); <INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/src/mono.sml b/src/mono.sml index 3e9e2638..913650fa 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -58,8 +58,8 @@ datatype exp' = withtype exp = exp' located datatype decl' = - DVal of string * int * typ * exp - | DPage of (string * typ) list * exp + DVal of string * int * typ * exp * string + | DExport of int withtype decl = decl' located diff --git a/src/mono_env.sig b/src/mono_env.sig index f0d0b0a6..e1e78b48 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -40,8 +40,8 @@ signature MONO_ENV = sig 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 pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env + val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string val declBinds : env -> Mono.decl -> env diff --git a/src/mono_env.sml b/src/mono_env.sml index cfe7b159..9af80d23 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -39,7 +39,7 @@ type env = { namedT : (string * typ option) IM.map, relE : (string * typ) list, - namedE : (string * typ * exp option) IM.map + namedE : (string * typ * exp option * string) IM.map } val empty = { @@ -70,11 +70,11 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n -fun pushENamed (env : env) x n t eo = +fun pushENamed (env : env) x n t eo s = {namedT = #namedT env, relE = #relE env, - namedE = IM.insert (#namedE env, n, (x, t, eo))} + namedE = IM.insert (#namedE env, n, (x, t, eo, s))} fun lookupENamed (env : env) n = case IM.find (#namedE env, n) of @@ -83,7 +83,7 @@ fun lookupENamed (env : env) n = fun declBinds env (d, _) = case d of - DVal (x, n, t, e) => pushENamed env x n t (SOME e) - | DPage _ => env + DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s + | DExport _ => env end diff --git a/src/mono_print.sml b/src/mono_print.sml index 3797aefa..a936c146 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -62,6 +62,12 @@ fun p_typ' par env (t, _) = and p_typ env = p_typ' false env +fun p_enamed env n = + if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n)) + fun p_exp' par env (e, _) = case e of EPrim p => Prim.p_t p @@ -70,11 +76,8 @@ fun p_exp' par env (e, _) = 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)) + | ENamed n => p_enamed env n + | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] | EFfiApp (m, x, es) => box [string "FFI(", string m, @@ -131,7 +134,7 @@ and p_exp env = p_exp' false env fun p_decl env ((d, _) : decl) = case d of - DVal (x, n, t, e) => + DVal (x, n, t, e, s) => let val xp = if !debug then box [string x, @@ -144,6 +147,10 @@ fun p_decl env ((d, _) : decl) = space, xp, space, + string "as", + space, + string s, + space, string ":", space, p_typ env t, @@ -152,19 +159,10 @@ fun p_decl env ((d, _) : decl) = space, p_exp env e] end - | DPage (xcs, e) => box [string "page", - string "[", - p_list (fn (x, t) => - box [string x, - space, - string ":", - space, - p_typ env t]) xcs, - string "]", - space, - string "=", - space, - p_exp env e] + + | DExport n => box [string "export", + space, + p_enamed env n] fun p_file env file = let diff --git a/src/mono_util.sig b/src/mono_util.sig index ab851aea..4a48671d 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -28,6 +28,9 @@ signature MONO_UTIL = sig structure Typ : sig + val compare : Mono.typ * Mono.typ -> order + val sortFields : (string * Mono.typ) list -> (string * Mono.typ) list + val mapfold : (Mono.typ', 'state, 'abort) Search.mapfolder -> (Mono.typ, 'state, 'abort) Search.mapfolder @@ -44,7 +47,7 @@ structure Exp : sig datatype binder = NamedT of string * int * Mono.typ option | RelE of string * Mono.typ - | NamedE of string * int * Mono.typ * Mono.exp option + | NamedE of string * int * Mono.typ * Mono.exp option * string val mapfoldB : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder, exp : ('typtext, Mono.exp', 'state, 'abort) Search.mapfolderB, diff --git a/src/mono_util.sml b/src/mono_util.sml index d5c047a7..1a7c8f5b 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -33,6 +33,48 @@ structure S = Search structure Typ = struct +fun join (o1, o2) = + case o1 of + EQUAL => o2 () + | v => v + +fun joinL f (os1, os2) = + case (os1, os2) of + (nil, nil) => EQUAL + | (nil, _) => LESS + | (h1 :: t1, h2 :: t2) => + join (f (h1, h2), fn () => joinL f (t1, t2)) + | (_ :: _, nil) => GREATER + +fun compare ((t1, _), (t2, _)) = + case (t1, t2) of + (TFun (d1, r1), TFun (d2, r2)) => + join (compare (d1, d2), fn () => compare (r1, r2)) + | (TRecord xts1, TRecord xts2) => + let + val xts1 = sortFields xts1 + val xts2 = sortFields xts2 + in + joinL compareFields (xts1, xts2) + end + | (TNamed n1, TNamed n2) => Int.compare (n1, n2) + | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) + + | (TFun _, _) => LESS + | (_, TFun _) => GREATER + + | (TRecord _, _) => LESS + | (_, TRecord _) => GREATER + + | (TNamed _, _) => LESS + | (_, TNamed _) => GREATER + +and compareFields ((x1, t1), (x2, t2)) = + join (String.compare (x1, x2), + fn () => compare (t1, t2)) + +and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts + fun mapfold fc = let fun mft c acc = @@ -85,7 +127,7 @@ structure Exp = struct datatype binder = NamedT of string * int * typ option | RelE of string * typ - | NamedE of string * int * typ * exp option + | NamedE of string * int * typ * exp option * string fun mapfoldB {typ = fc, exp = fe, bind} = let @@ -211,21 +253,13 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = and mfd' ctx (dAll as (d, loc)) = case d of - DVal (x, n, t, e) => + DVal (x, n, t, e, s) => S.bind2 (mft t, fn t' => S.map2 (mfe ctx e, fn e' => - (DVal (x, n, t', e'), loc))) - | DPage (xts, e) => - S.bind2 (ListUtil.mapfold (fn (x, t) => - S.map2 (mft t, - fn t' => - (x, t'))) xts, - fn xts' => - S.map2 (mfe ctx e, - fn e' => - (DPage (xts', e'), loc))) + (DVal (x, n, t', e', s), loc))) + | DExport _ => S.return2 dAll in mfd end @@ -262,8 +296,8 @@ fun mapfoldB (all as {bind, ...}) = let val ctx' = case #1 d' of - DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e)) - | DPage _ => ctx + DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s)) + | DExport _ => ctx in S.map2 (mff ctx' ds', fn ds' => diff --git a/src/monoize.sml b/src/monoize.sml index 1d95a303..5f5db692 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -203,15 +203,9 @@ fun monoDecl env (all as (d, loc)) = 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)) - | L.DPage ((c, _), e) => - (case c of - L.CRecord (_, vs) => SOME (env, - (L'.DPage (map (fn (nm, t) => (monoName env nm, - monoType env t)) vs, - monoExp env e), loc)) - | _ => poly ()) + | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s, + (L'.DVal (x, n, monoType env t, monoExp env e, s), loc)) + | L.DExport n => SOME (env, (L'.DExport n, loc)) end fun monoize env ds = diff --git a/src/reduce.sml b/src/reduce.sml index 967eb790..cdf24725 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -115,7 +115,7 @@ fun bind (env, b) = U.Decl.RelC (x, k) => E.pushCRel env x k | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co | U.Decl.RelE (x, t) => E.pushERel env x t - | U.Decl.NamedE (x, n, t, eo) => E.pushENamed env x n t eo + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s fun kind k = k @@ -143,7 +143,7 @@ fun exp env e = case e of ENamed n => (case E.lookupENamed env n of - (_, _, SOME e') => #1 e' + (_, _, SOME e', _) => #1 e' | _ => e) | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) => diff --git a/src/shake.sml b/src/shake.sml index 36657dfc..b7ce58d7 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -43,13 +43,13 @@ type free = { fun shake file = let - val (page_cs, page_es) = List.foldl - (fn ((DPage (c, e), _), (cs, es)) => (c :: cs, e :: es) - | (_, acc) => acc) ([], []) file + val page_es = List.foldl + (fn ((DExport n, _), page_es) => n :: page_es + | (_, page_es) => page_es) [] file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef) - | ((DVal (_, n, t, e), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) - | ((DPage _, _), acc) => acc) + | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) + | ((DExport _, _), acc) => acc) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -90,14 +90,16 @@ fun shake file = and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s - val s = {con = IS.empty, exp = IS.empty} - - val s = foldl (fn (c, s) => U.Con.fold {kind = kind, con = con} s c) s page_cs - val s = foldl (fn (e, s) => U.Exp.fold {kind = kind, con = con, exp = exp} s e) s page_es + val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)} + + val s = foldl (fn (n, s) => + case IM.find (edef, n) of + NONE => raise Fail "Shake: Couldn't find 'val'" + | SOME (t, e) => shakeExp (shakeCon s t) e) s page_es in List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n) - | (DVal (_, n, _, _), _) => IS.member (#exp s, n) - | (DPage _, _) => true) file + | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) + | (DExport _, _) => true) file end end diff --git a/src/source.sml b/src/source.sml index e52f5630..d5aa137e 100644 --- a/src/source.sml +++ b/src/source.sml @@ -113,7 +113,7 @@ datatype decl' = | DOpen of string * string list | DConstraint of con * con | DOpenConstraints of string * string list - | DPage of exp + | DExport of str and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 827bb554..760f46bf 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -418,9 +418,9 @@ fun p_decl ((d, _) : decl) = space, p_list_sep (string ".") string (m :: ms)] - | DPage e => box [string "page", - space, - p_exp e] + | DExport str => box [string "export", + space, + p_str str] and p_str (str, _) = case str of diff --git a/src/sources b/src/sources index c4b9849e..7faec26b 100644 --- a/src/sources +++ b/src/sources @@ -92,20 +92,6 @@ monoize.sml mono_opt.sig mono_opt.sml -flat.sml - -flat_util.sig -flat_util.sml - -flat_env.sig -flat_env.sml - -flat_print.sig -flat_print.sml - -cloconv.sig -cloconv.sml - cjr.sml cjr_env.sig |