summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/jscomp.sml7
-rw-r--r--src/mono_util.sig6
-rw-r--r--src/mono_util.sml21
-rw-r--r--src/name_js.sml26
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