Mercurial > urweb

comparison src/elaborate.sml @ 1294:b4480a56cab7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Server-side 'onError'
author Adam Chlipala <adam@chlipala.net>
date Tue, 07 Sep 2010 08:28:07 -0400
parents 1e6a4f9d3e4a
children 3c334458c84f
comparison
equal deleted inserted replaced
1293:acabf3935060 1294:b4480a56cab7
2677 | L'.DDatabase _ => [] 2677 | L'.DDatabase _ => []
2678 | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] 2678 | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
2679 | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] 2679 | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
2680 | L'.DTask _ => [] 2680 | L'.DTask _ => []
2681 | L'.DPolicy _ => [] 2681 | L'.DPolicy _ => []
2682 | L'.DOnError _ => []
2682 2683
2683 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = 2684 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
2684 ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), 2685 ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
2685 ("sgn2", p_sgn env sgn2)];*) 2686 ("sgn2", p_sgn env sgn2)];*)
2686 case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of 2687 case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of
3855 val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc) 3856 val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc)
3856 in 3857 in
3857 checkCon env e1' t1 t1'; 3858 checkCon env e1' t1 t1';
3858 ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) 3859 ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs))
3859 end 3860 end
3861
3862 | L.DOnError (m1, ms, s) =>
3863 (case E.lookupStr env m1 of
3864 NONE => (expError env (UnboundStrInExp (loc, m1));
3865 ([], (env, denv, [])))
3866 | SOME (n, sgn) =>
3867 let
3868 val (str, sgn) = foldl (fn (m, (str, sgn)) =>
3869 case E.projectStr env {sgn = sgn, str = str, field = m} of
3870 NONE => (conError env (UnboundStrInCon (loc, m));
3871 (strerror, sgnerror))
3872 | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
3873 ((L'.StrVar n, loc), sgn) ms
3874
3875 val t = case E.projectVal env {sgn = sgn, str = str, field = s} of
3876 NONE => (expError env (UnboundExp (loc, s));
3877 cerror)
3878 | SOME t => t
3879
3880 val page = (L'.CModProj (!basis_r, [], "page"), loc)
3881 val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc)
3882 val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc)
3883 in
3884 unifyCons env loc t func;
3885 ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs))
3886 end)
3860 3887
3861 (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) 3888 (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
3862 in 3889 in
3863 (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) 3890 (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*)
3864 r 3891 r