Mercurial > urweb

comparison src/corify.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents 5f04adf47f48
children 3739af9e727a
comparison
equal deleted inserted replaced
108:f59553dc1b6a 109:813e5a52063d
360 360
361 | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) 361 | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc)
362 | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, 362 | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c,
363 {field = corifyCon st field, rest = corifyCon st rest}), loc) 363 {field = corifyCon st field, rest = corifyCon st rest}), loc)
364 | L.EFold k => (L'.EFold (corifyKind k), loc) 364 | L.EFold k => (L'.EFold (corifyKind k), loc)
365 | L.EWrite e => (L'.EWrite (corifyExp st e), loc)
365 366
366 fun corifyDecl ((d, loc : EM.span), st) = 367 fun corifyDecl ((d, loc : EM.span), st) =
367 case d of 368 case d of
368 L.DCon (x, n, k, c) => 369 L.DCon (x, n, k, c) =>
369 let 370 let
373 end 374 end
374 | L.DVal (x, n, t, e) => 375 | L.DVal (x, n, t, e) =>
375 let 376 let
376 val (st, n) = St.bindVal st x n 377 val (st, n) = St.bindVal st x n
377 in 378 in
378 ([(L'.DVal (x, n, corifyCon st t, corifyExp st e), loc)], st) 379 ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, x), loc)], st)
379 end 380 end
380 381
381 | L.DSgn _ => ([], st) 382 | L.DSgn _ => ([], st)
382 383
383 | L.DStr (x, n, _, (L.StrFun (_, na, _, _, str), _)) => 384 | L.DStr (x, n, _, (L.StrFun (_, na, _, _, str), _)) =>
425 in 426 in
426 (rev ds, st) 427 (rev ds, st)
427 end 428 end
428 | _ => raise Fail "Non-const signature for FFI structure") 429 | _ => raise Fail "Non-const signature for FFI structure")
429 430
430 | L.DPage (c, e) => 431 | L.DExport (en, sgn, str) =>
431 let 432 (case #1 sgn of
432 val c = corifyCon st c 433 L.SgnConst sgis =>
433 val e = corifyExp st e 434 let
434 435 fun pathify (str, _) =
435 val dom = (L'.TRecord c, loc) 436 case str of
436 val ran = (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc) 437 L.StrVar m => SOME (m, [])
437 val e = (L'.EAbs ("vs", dom, ran, 438 | L.StrProj (str, s) =>
438 (L'.EWrite (L'.EApp (e, (L'.ERel 0, loc)), loc), loc)), loc) 439 Option.map (fn (m, ms) => (m, ms @ [s])) (pathify str)
439 440 | _ => NONE
440 in 441 in
441 ([(L'.DPage (c, e), loc)], st) 442 case pathify str of
442 end 443 NONE => (ErrorMsg.errorAt loc "Structure is too fancy to export";
444 ([], st))
445 | SOME (m, ms) =>
446 let
447 fun wrapSgi ((sgi, _), (wds, eds)) =
448 case sgi of
449 L.SgiVal (s, _, t as (L.TFun (dom, ran), _)) =>
450 (case (#1 dom, #1 ran) of
451 (L.TRecord _,
452 L.CApp ((L.CModProj (_, [], "xml"), _),
453 (L.TRecord (L.CRecord (_, [((L.CName "Html", _),
454 _)]), _), _))) =>
455 let
456 val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc)
457 val e = (L.EModProj (m, ms, s), loc)
458 val e = (L.EAbs ("vs", dom, ran,
459 (L.EWrite (L.EApp (e, (L.ERel 0, loc)), loc), loc)), loc)
460 in
461 ((L.DVal ("wrap_" ^ s, 0,
462 (L.TFun (dom, ran), loc),
463 e), loc) :: wds,
464 (fn st =>
465 case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of
466 L'.ENamed n => (L'.DExport n, loc)
467 | _ => raise Fail "Corify: Value to export didn't corify properly")
468 :: eds)
469 end
470 | _ => (wds, eds))
471 | _ => (wds, eds)
472
473 val (wds, eds) = foldl wrapSgi ([], []) sgis
474 val wrapper = (L.StrConst wds, loc)
475 val (ds, {inner, outer}) = corifyStr (wrapper, st)
476 val st = St.bindStr outer "wrapper" en inner
477
478 val ds = ds @ map (fn f => f st) eds
479 in
480 (ds, st)
481 end
482 end
483 | _ => raise Fail "Non-const signature for 'export'")
484
443 485
444 and corifyStr ((str, _), st) = 486 and corifyStr ((str, _), st) =
445 case str of 487 case str of
446 L.StrConst ds => 488 L.StrConst ds =>
447 let 489 let
485 L.DCon (_, n', _, _) => Int.max (n, n') 527 L.DCon (_, n', _, _) => Int.max (n, n')
486 | L.DVal (_, n', _ , _) => Int.max (n, n') 528 | L.DVal (_, n', _ , _) => Int.max (n, n')
487 | L.DSgn (_, n', _) => Int.max (n, n') 529 | L.DSgn (_, n', _) => Int.max (n, n')
488 | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)) 530 | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))
489 | L.DFfiStr (_, n', _) => Int.max (n, n') 531 | L.DFfiStr (_, n', _) => Int.max (n, n')
490 | L.DPage _ => n) 532 | L.DExport _ => n)
491 0 ds 533 0 ds
492 534
493 and maxNameStr (str, _) = 535 and maxNameStr (str, _) =
494 case str of 536 case str of
495 L.StrConst ds => maxName ds 537 L.StrConst ds => maxName ds