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>