diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/jscomp.sml | 7 | ||||
| -rw-r--r-- | src/mono_util.sig | 6 | ||||
| -rw-r--r-- | src/mono_util.sml | 21 | ||||
| -rw-r--r-- | src/name_js.sml | 26 |
4 files changed, 53 insertions, 7 deletions
diff --git a/src/jscomp.sml b/src/jscomp.sml index ffb68ab2..887fbc87 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -507,13 +507,14 @@ fun process (file : file) = 0 => s | _ => jsifyStringMulti (n - 1, jsifyString s) - fun deStrcat level (all as (e, _)) = + fun deStrcat level (all as (e, loc)) = case e of EPrim (Prim.String s) => jsifyStringMulti (level, s) | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\"" - | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; - raise Fail "Jscomp: deStrcat") + | _ => (ErrorMsg.errorAt loc "Unexpected non-constant JavaScript code"; + Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; + "") val quoteExp = quoteExp loc in diff --git a/src/mono_util.sig b/src/mono_util.sig index a5118072..da8b2e20 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -117,6 +117,10 @@ structure Decl : sig decl : 'context * Mono.decl' * 'state -> Mono.decl' * 'state, bind : 'context * binder -> 'context} -> 'context -> 'state -> Mono.decl -> Mono.decl * 'state + + val exists : {typ : Mono.typ' -> bool, + exp : Mono.exp' -> bool, + decl : Mono.decl' -> bool} -> Mono.decl -> bool end structure File : sig diff --git a/src/mono_util.sml b/src/mono_util.sml index 61638858..116dfa64 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -654,6 +654,25 @@ fun foldMapB {typ, exp, decl, bind} ctx s d = S.Continue v => v | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible" +fun exists {typ, exp, decl} 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, ()), + decl = fn d => fn () => + if decl d then + S.Return () + else + S.Continue (d, ())} k () of + S.Return _ => true + | S.Continue _ => false + end structure File = struct diff --git a/src/name_js.sml b/src/name_js.sml index 53abd7a3..f10e5938 100644 --- a/src/name_js.sml +++ b/src/name_js.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2012, Adam Chlipala +(* Copyright (c) 2012-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -72,6 +72,28 @@ fun squish vs = U.Exp.mapB {typ = fn x => x, fun rewrite file = let + fun isTricky' dontName e = + case e of + ENamed n => IS.member (dontName, n) + | EFfiApp ("Basis", "sigString", _) => true + | _ => false + + fun isTricky dontName = U.Decl.exists {typ = fn _ => false, + exp = isTricky' dontName, + decl = fn _ => false} + + fun isTrickyE dontName = U.Exp.exists {typ = fn _ => false, + exp = isTricky' dontName} + + val dontName = foldl (fn (d, dontName) => + if isTricky dontName d then + case #1 d of + DVal (_, n, _, _, _) => IS.add (dontName, n) + | DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis + | _ => dontName + else + dontName) IS.empty (#1 file) + val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) => let val (d, (nextName, newDs)) = @@ -96,7 +118,7 @@ fun rewrite file = EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e | _ => isTrulySimple e in - if isAlreadySimple e' then + if isAlreadySimple e' orelse isTrickyE dontName e' then (e, st) else let |