Mercurial > urweb
changeset 1628:3621f486ce72
Don't crash on invalid URL head terms during Tag
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sat, 03 Dec 2011 17:25:51 -0500 |
| parents | 5c1f10cdac63 |
| children | 438561303d02 |
| files | src/tag.sml tests/invurl.ur |
| diffstat | 2 files changed, 41 insertions(+), 27 deletions(-) [+] |
line wrap: on
line diff
--- a/src/tag.sml Sat Dec 03 17:07:34 2011 -0500 +++ b/src/tag.sml Sat Dec 03 17:25:51 2011 -0500 @@ -65,38 +65,43 @@ | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr ^ " expression"); Print.epreface ("Expression", - CorePrint.p_exp CoreEnv.empty eOrig); + CorePrint.p_exp env eOrig); (0, [])) val (f, args) = unravel e + in + if f = 0 then + (e, (count, tags, byTag, newTags)) + else + let + val (cn, count, tags, newTags) = + case IM.find (tags, f) of + NONE => + (count, count + 1, IM.insert (tags, f, count), + (ek, f, count) :: newTags) + | SOME cn => (cn, count, tags, newTags) + + val (_, _, _, s) = E.lookupENamed env f - val (cn, count, tags, newTags) = - case IM.find (tags, f) of - NONE => - (count, count + 1, IM.insert (tags, f, count), - (ek, f, count) :: newTags) - | SOME cn => (cn, count, tags, newTags) - - val (_, _, _, s) = E.lookupENamed env f + val byTag = case SM.find (byTag, s) of + NONE => SM.insert (byTag, s, (ek, f)) + | SOME (ek', f') => + (if f = f' then + () + else + ErrorMsg.errorAt loc + ("Duplicate HTTP tag " + ^ s); + if ek = ek' then + () + else + both (loc, s); + byTag) - val byTag = case SM.find (byTag, s) of - NONE => SM.insert (byTag, s, (ek, f)) - | SOME (ek', f') => - (if f = f' then - () - else - ErrorMsg.errorAt loc - ("Duplicate HTTP tag " - ^ s); - if ek = ek' then - () - else - both (loc, s); - byTag) - - val e = (EClosure (cn, args), loc) - in - (e, (count, tags, byTag, newTags)) + val e = (EClosure (cn, args), loc) + in + (e, (count, tags, byTag, newTags)) + end end in case e of
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/invurl.ur Sat Dec 03 17:25:51 2011 -0500 @@ -0,0 +1,9 @@ +val r = { F = fn () => return <xml/> } + +fun main () : transaction page = return <xml><body> + <a link={r.F ()}>Go</a> +</body></xml> + +fun main' (r' : {F : unit -> transaction page}) : transaction page = return <xml><body> + <a link={r'.F ()}>Go</a> +</body></xml>