Mercurial > urweb
comparison src/corify.sml @ 2206:c1a62ce47083
Merge.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Tue, 27 May 2014 21:38:01 -0400 |
parents | 403f0cc65b9c |
children | ec2c7a22df0d |
comparison
equal
deleted
inserted
replaced
2205:cdea39473c78 | 2206:c1a62ce47083 |
---|---|
640 loc) | 640 loc) |
641 | 641 |
642 | L.EWrite e => (L'.EWrite (corifyExp st e), loc) | 642 | L.EWrite e => (L'.EWrite (corifyExp st e), loc) |
643 | 643 |
644 | L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc) | 644 | L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc) |
645 | |
646 fun isTransactional (c, _) = | |
647 case c of | |
648 L'.TFun (_, c) => isTransactional c | |
649 | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true | |
650 | _ => false | |
645 | 651 |
646 fun corifyDecl mods (all as (d, loc : EM.span), st) = | 652 fun corifyDecl mods (all as (d, loc : EM.span), st) = |
647 case d of | 653 case d of |
648 L.DCon (x, n, k, c) => | 654 L.DCon (x, n, k, c) => |
649 let | 655 let |
968 corifyCon st all | 974 corifyCon st all |
969 | _ => corifyCon st all | 975 | _ => corifyCon st all |
970 in | 976 in |
971 transactify c | 977 transactify c |
972 end | 978 end |
973 | |
974 fun isTransactional (c, _) = | |
975 case c of | |
976 L'.TFun (_, c) => isTransactional c | |
977 | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true | |
978 | _ => false | |
979 in | 979 in |
980 if isTransactional c then | 980 if isTransactional c then |
981 let | 981 let |
982 val ffi = (m, x) | 982 val ffi = (m, x) |
983 in | 983 in |
1162 St.ENormal n => ([(L'.DOnError n, loc)], st) | 1162 St.ENormal n => ([(L'.DOnError n, loc)], st) |
1163 | _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'"; | 1163 | _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'"; |
1164 ([], st)) | 1164 ([], st)) |
1165 end | 1165 end |
1166 | 1166 |
1167 | L.DFfi (x, n, modes, t) => | |
1168 let | |
1169 val m = case St.name st of | |
1170 [m] => m | |
1171 | _ => (ErrorMsg.errorAt loc "Used 'ffi' declaration beneath module top level"; | |
1172 "") | |
1173 | |
1174 val name = (m, x) | |
1175 | |
1176 val (st, n) = St.bindVal st x n | |
1177 val s = doRestify Settings.Url (mods, x) | |
1178 | |
1179 val t' = corifyCon st t | |
1180 | |
1181 fun numArgs (t : L'.con) = | |
1182 case #1 t of | |
1183 L'.TFun (_, ran) => 1 + numArgs ran | |
1184 | _ => 0 | |
1185 | |
1186 fun makeArgs (i, t : L'.con, acc) = | |
1187 case #1 t of | |
1188 L'.TFun (dom, ran) => makeArgs (i-1, ran, ((L'.ERel i, loc), dom) :: acc) | |
1189 | _ => rev acc | |
1190 | |
1191 fun wrapAbs (i, t : L'.con, tTrans, e) = | |
1192 case (#1 t, #1 tTrans) of | |
1193 (L'.TFun (dom, ran), L'.TFun (_, ran')) => (L'.EAbs ("x" ^ Int.toString i, dom, ran, wrapAbs (i+1, ran, ran', e)), loc) | |
1194 | _ => e | |
1195 | |
1196 fun getRan (t : L'.con) = | |
1197 case #1 t of | |
1198 L'.TFun (_, ran) => getRan ran | |
1199 | _ => t | |
1200 | |
1201 fun addLastBit (t : L'.con) = | |
1202 case #1 t of | |
1203 L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t) | |
1204 | _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc) | |
1205 | |
1206 val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - 1, t', [])), loc) | |
1207 val (e, tTrans) = if isTransactional t' then | |
1208 ((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t') | |
1209 else | |
1210 (e, t') | |
1211 val e = wrapAbs (0, t', tTrans, e) | |
1212 in | |
1213 app (fn Source.Effectful => Settings.addEffectful name | |
1214 | Source.BenignEffectful => Settings.addBenignEffectful name | |
1215 | Source.ClientOnly => Settings.addClientOnly name | |
1216 | Source.ServerOnly => Settings.addServerOnly name | |
1217 | Source.JsFunc s => Settings.addJsFunc (name, s)) modes; | |
1218 | |
1219 if isTransactional t' andalso not (Settings.isBenignEffectful name) then | |
1220 Settings.addEffectful name | |
1221 else | |
1222 (); | |
1223 | |
1224 ([(L'.DVal (x, n, t', e, s), loc)], st) | |
1225 end | |
1226 | |
1167 and corifyStr mods ((str, loc), st) = | 1227 and corifyStr mods ((str, loc), st) = |
1168 case str of | 1228 case str of |
1169 L.StrConst ds => | 1229 L.StrConst ds => |
1170 let | 1230 let |
1171 val st = St.enter (st, mods) | 1231 val st = St.enter (st, mods) |
1235 | L.DDatabase _ => n | 1295 | L.DDatabase _ => n |
1236 | L.DCookie (_, _, n', _) => Int.max (n, n') | 1296 | L.DCookie (_, _, n', _) => Int.max (n, n') |
1237 | L.DStyle (_, _, n') => Int.max (n, n') | 1297 | L.DStyle (_, _, n') => Int.max (n, n') |
1238 | L.DTask _ => n | 1298 | L.DTask _ => n |
1239 | L.DPolicy _ => n | 1299 | L.DPolicy _ => n |
1240 | L.DOnError _ => n) | 1300 | L.DOnError _ => n |
1301 | L.DFfi (_, n', _, _) => Int.max (n, n')) | |
1241 0 ds | 1302 0 ds |
1242 | 1303 |
1243 and maxNameStr (str, _) = | 1304 and maxNameStr (str, _) = |
1244 case str of | 1305 case str of |
1245 L.StrConst ds => maxName ds | 1306 L.StrConst ds => maxName ds |