diff options
author | Adam Chlipala <adamc@hcoop.net> | 2009-06-02 19:28:25 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2009-06-02 19:28:25 -0400 |
commit | a144d74a7fb416108f643daaa3a734e416683737 (patch) | |
tree | 426b37ee6b714afc0a597600850846d73c9d41a7 /src | |
parent | 1fd04be40e1f4885753a269b898d1bd11d24672d (diff) |
Lexing some more string escape sequences; JS versions of number read; fix problem with signature unification; escape < more often in Jscomp
Diffstat (limited to 'src')
-rw-r--r-- | src/elaborate.sml | 66 | ||||
-rw-r--r-- | src/jscomp.sml | 4 | ||||
-rw-r--r-- | src/settings.sml | 2 | ||||
-rw-r--r-- | src/urweb.grm | 5 | ||||
-rw-r--r-- | src/urweb.lex | 17 |
5 files changed, 60 insertions, 34 deletions
diff --git a/src/elaborate.sml b/src/elaborate.sml index 64b690ef..d60f19f7 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -158,7 +158,7 @@ "U" ^ Int.toString (n - 26) in count := n + 1; - (L'.KUnif (loc, s, ref NONE), dummy) + (L'.KUnif (loc, s, ref NONE), loc) end end @@ -178,7 +178,7 @@ "U" ^ Int.toString (n - 26) in count := n + 1; - (L'.CUnif (loc, k, s, ref NONE), dummy) + (L'.CUnif (loc, k, s, ref NONE), loc) end end @@ -776,7 +776,7 @@ | orig as ([(_, r1 as ref NONE)], _, [], [(_, r2 as ref NONE)], _, []) => if List.all (fn (x1, _) => List.all (fn (x2, _) => consNeq env (x1, x2)) fs2) fs1 then let - val kr = (L'.KRecord k, dummy) + val kr = (L'.KRecord k, loc) val u = cunif (loc, kr) in r1 := SOME (L'.CConcat ((L'.CRecord (k, fs2), loc), u), loc); @@ -817,7 +817,7 @@ (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) - val empty = (L'.CRecord (k, []), dummy) + val empty = (L'.CRecord (k, []), loc) fun failure () = raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2)) in (case (unifs1, fs1, others1, unifs2, fs2, others2) of @@ -1652,7 +1652,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val dom = cunif (loc, ktype) val ran = cunif (loc, ktype) - val t = (L'.TFun (dom, ran), dummy) + val t = (L'.TFun (dom, ran), loc) in checkCon env e1' t1 t; checkCon env e2' t2 dom; @@ -2507,7 +2507,7 @@ and sgiOfDecl (d, loc) = | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] -and subSgn env sgn1 (sgn2 as (_, loc2)) = +and subSgn' counterparts env sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), ("sgn2", p_sgn env sgn2)];*) case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of @@ -2521,6 +2521,18 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)), ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*) + fun cpart n = IM.find (!counterparts, n) + fun cparts (n2, n1) = counterparts := IM.insert (!counterparts, n2, n1) + + val sub2 = U.Con.map {kind = fn k => k, + con = fn c => + case c of + L'.CNamed n2 => + (case cpart n2 of + NONE => c + | SOME n1 => L'.CNamed n1) + | _ => c} + fun folder (sgi2All as (sgi, loc), env) = let (*val () = prefaces "folder" [("sgis1", p_sgn env (L'.SgnConst sgis1, loc2))]*) @@ -2572,7 +2584,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = SOME (if n1 = n2 then env else - E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2))) + (cparts (n2, n1); + E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2)))) end else NONE @@ -2616,6 +2629,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = fun found (x', n1, k1, c1) = if x = x' then let + val c2 = sub2 c2 + fun good () = let val env = E.pushCNamedAs env x n2 k2 (SOME c2) @@ -2662,8 +2677,9 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = val env = if n1 = n2 then env else - E.pushCNamedAs env x1 n2 k' - (SOME (L'.CNamed n1, loc)) + (cparts (n2, n1); + E.pushCNamedAs env x1 n2 k' + (SOME (L'.CNamed n1, loc))) in SOME env end @@ -2672,14 +2688,15 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = val env = if n1 = n2 then env else - E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc)) + (cparts (n2, n1); + E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc))) val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 fun xncBad ((x1, _, t1), (x2, _, t2)) = String.compare (x1, x2) <> EQUAL orelse case (t1, t2) of (NONE, NONE) => false | (SOME t1, SOME t2) => - (unifyCons env t1 t2; false) + (unifyCons env t1 (sub2 t2); false) | _ => true in (if xs1 <> xs2 @@ -2746,6 +2763,7 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = val env = E.pushCNamedAs env x n1 k' (SOME t1) val env = E.pushCNamedAs env x n2 k' (SOME t2) in + cparts (n2, n1); SOME env end in @@ -2765,7 +2783,12 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = case sgi1 of L'.SgiVal (x', n1, c1) => if x = x' then - (unifyCons env c1 c2; + ((*prefaces "val" [("x", PD.string x), + ("n1", PD.string (Int.toString n1)), + ("c1", p_con env c1), + ("c2", p_con env c2), + ("c2'", p_con env (sub2 c2))];*) + unifyCons env c1 (sub2 c2); SOME env) handle CUnify (c1, c2, err) => (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); @@ -2780,7 +2803,7 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = L'.SgiStr (x', n1, sgn1) => if x = x' then let - val () = subSgn env sgn1 sgn2 + val () = subSgn' counterparts env sgn1 sgn2 val env = E.pushStrNamedAs env x n1 sgn1 val env = if n1 = n2 then env @@ -2801,14 +2824,15 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = L'.SgiSgn (x', n1, sgn1) => if x = x' then let - val () = subSgn env sgn1 sgn2 - val () = subSgn env sgn2 sgn1 + val () = subSgn' counterparts env sgn1 sgn2 + val () = subSgn' counterparts env sgn2 sgn1 val env = E.pushSgnNamedAs env x n2 sgn2 val env = if n1 = n2 then env else - E.pushSgnNamedAs env x n1 sgn2 + (cparts (n2, n1); + E.pushSgnNamedAs env x n1 sgn2) in SOME env end @@ -2841,7 +2865,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = SOME (if n1 = n2 then env else - E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2))) + (cparts (n2, n1); + E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2)))) end else NONE @@ -2861,6 +2886,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = handle KUnify (k1, k2, err) => sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) + val c2 = sub2 c2 + fun good () = let val env = E.pushCNamedAs env x n2 k2 (SOME c2) @@ -2898,12 +2925,13 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) = else subStrInSgn (n2, n1) ran2 in - subSgn env dom2 dom1; - subSgn (E.pushStrNamedAs env m1 n1 dom2) ran1 ran2 + subSgn' counterparts env dom2 dom1; + subSgn' counterparts (E.pushStrNamedAs env m1 n1 dom2) ran1 ran2 end | _ => sgnError env (SgnWrongForm (sgn1, sgn2))) +and subSgn env = subSgn' (ref IM.empty) env and positive self = let diff --git a/src/jscomp.sml b/src/jscomp.sml index 91ac0acb..0178888a 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -523,9 +523,9 @@ fun process file = "'" | #"\"" => "\\\"" | #"<" => - if mode = Script then + (*if mode = Script then "<" - else + else*) "\\074" | #"\\" => "\\\\" | #"\n" => "\\n" diff --git a/src/settings.sml b/src/settings.sml index a71ab872..e5b42abc 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -131,6 +131,8 @@ val jsFuncsBase = basisM [("alert", "alert"), ("htmlifyString", "eh"), ("new_client_source", "sc"), ("set_client_source", "sv"), + ("stringToFloat", "pflo"), + ("stringToInt", "pio"), ("stringToFloat_error", "pfl"), ("stringToInt_error", "pi"), ("urlifyInt", "ts"), diff --git a/src/urweb.grm b/src/urweb.grm index 1bb5da58..0232a3f3 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -959,11 +959,6 @@ eexp : eapps (eapps) end) bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps) - | UNIT LARROW eapps (let - val loc = s (UNITleft, eappsright) - in - ("_", SOME (TRecord (CRecord [], loc), loc), eapps) - end) | eapps (let val loc = s (eappsleft, eappsright) in diff --git a/src/urweb.lex b/src/urweb.lex index b2f715d5..c23dfe62 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -193,11 +193,15 @@ notags = [^<{\n]+; <COMMENT> "*)" => (if exitComment () then YYBEGIN INITIAL else (); continue ()); -<INITIAL> "#\"" => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue()); -<CHAR> "\\\"" => (str := #"\"" :: !str; continue()); -<CHAR> "\\'" => (str := #"'" :: !str; continue()); -<CHAR> "\n" => (newline yypos; +<STRING,CHAR> "\\\"" => (str := #"\"" :: !str; continue()); +<STRING,CHAR> "\\'" => (str := #"'" :: !str; continue()); +<STRING,CHAR> "\\n" => (str := #"\n" :: !str; continue()); +<STRING,CHAR> "\\t" => (str := #"\t" :: !str; continue()); +<STRING,CHAR> "\n" => (newline yypos; str := #"\n" :: !str; continue()); + +<INITIAL> "#\"" => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue()); + <CHAR> . => (let val ch = String.sub (yytext, 0) in @@ -220,10 +224,7 @@ notags = [^<{\n]+; <INITIAL> "\"" => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue()); <INITIAL> "'" => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue()); -<STRING> "\\\"" => (str := #"\"" :: !str; continue()); -<STRING> "\\'" => (str := #"'" :: !str; continue()); -<STRING> "\n" => (newline yypos; - str := #"\n" :: !str; continue()); + <STRING> . => (let val ch = String.sub (yytext, 0) in |