Mercurial > urweb

comparison src/corify.sml @ 339:075b36dbb1a4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Crud supports INSERT
author Adam Chlipala <adamc@hcoop.net>
date Sun, 14 Sep 2008 15:10:04 -0400
parents e976b187d73a
children 6fd102fa28f9
comparison
equal deleted inserted replaced
338:e976b187d73a 339:075b36dbb1a4
88 val lookupValByName : t -> string -> core_val 88 val lookupValByName : t -> string -> core_val
89 89
90 val bindStr : t -> string -> int -> t -> t 90 val bindStr : t -> string -> int -> t -> t
91 val lookupStrById : t -> int -> t 91 val lookupStrById : t -> int -> t
92 val lookupStrByName : string * t -> t 92 val lookupStrByName : string * t -> t
93 val lookupStrByNameOpt : string * t -> t option
93 94
94 val bindFunctor : t -> string -> int -> string -> int -> L.str -> t 95 val bindFunctor : t -> string -> int -> string -> int -> L.str -> t
95 val lookupFunctorById : t -> int -> string * int * L.str 96 val lookupFunctorById : t -> int -> string * int * L.str
96 val lookupFunctorByName : string * t -> string * int * L.str 97 val lookupFunctorByName : string * t -> string * int * L.str
97 end = struct 98 end = struct
361 NONE => raise Fail "Corify.St.lookupStrById" 362 NONE => raise Fail "Corify.St.lookupStrById"
362 | SOME f => dummy (basis, f) 363 | SOME f => dummy (basis, f)
363 364
364 fun lookupStrByName (m, {basis, current = FNormal {strs, ...}, ...} : t) = 365 fun lookupStrByName (m, {basis, current = FNormal {strs, ...}, ...} : t) =
365 (case SM.find (strs, m) of 366 (case SM.find (strs, m) of
366 NONE => raise Fail "Corify.St.lookupStrByName" 367 NONE => raise Fail "Corify.St.lookupStrByName [1]"
367 | SOME f => dummy (basis, f)) 368 | SOME f => dummy (basis, f))
368 | lookupStrByName _ = raise Fail "Corify.St.lookupStrByName" 369 | lookupStrByName _ = raise Fail "Corify.St.lookupStrByName [2]"
370
371 fun lookupStrByNameOpt (m, {basis, current = FNormal {strs, ...}, ...} : t) =
372 (case SM.find (strs, m) of
373 NONE => NONE
374 | SOME f => SOME (dummy (basis, f)))
375 | lookupStrByNameOpt _ = NONE
369 376
370 fun bindFunctor ({basis, cons, constructors, vals, strs, funs, 377 fun bindFunctor ({basis, cons, constructors, vals, strs, funs,
371 current = FNormal {cons = mcons, constructors = mconstructors, 378 current = FNormal {cons = mcons, constructors = mconstructors,
372 vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) 379 vals = mvals, strs = mstrs, funs = mfuns}, nested} : t)
373 x n xa na str = 380 x n xa na str =
390 NONE => raise Fail "Corify.St.lookupFunctorById" 397 NONE => raise Fail "Corify.St.lookupFunctorById"
391 | SOME v => v 398 | SOME v => v
392 399
393 fun lookupFunctorByName (m, {current = FNormal {funs, ...}, ...} : t) = 400 fun lookupFunctorByName (m, {current = FNormal {funs, ...}, ...} : t) =
394 (case SM.find (funs, m) of 401 (case SM.find (funs, m) of
395 NONE => raise Fail "Corify.St.lookupFunctorByName" 402 NONE => raise Fail "Corify.St.lookupFunctorByName [1]"
396 | SOME v => v) 403 | SOME v => v)
397 | lookupFunctorByName _ = raise Fail "Corify.St.lookupFunctorByName" 404 | lookupFunctorByName _ = raise Fail "Corify.St.lookupFunctorByName [2]"
398 405
399 end 406 end
400 407
401 408
402 fun corifyKind (k, loc) = 409 fun corifyKind (k, loc) =
528 535
529 | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => 536 | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) =>
530 (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) 537 (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc)
531 | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, 538 | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c,
532 {field = corifyCon st field, rest = corifyCon st rest}), loc) 539 {field = corifyCon st field, rest = corifyCon st rest}), loc)
540 | L.EWith (e1, c, e2, {field, rest}) => (L'.EWith (corifyExp st e1, corifyCon st c, corifyExp st e2,
541 {field = corifyCon st field, rest = corifyCon st rest}), loc)
533 | L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c, 542 | L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c,
534 {field = corifyCon st field, rest = corifyCon st rest}), loc) 543 {field = corifyCon st field, rest = corifyCon st rest}), loc)
535 | L.EFold k => (L'.EFold (corifyKind k), loc) 544 | L.EFold k => (L'.EFold (corifyKind k), loc)
536 545
537 | L.ECase (e, pes, {disc, result}) => 546 | L.ECase (e, pes, {disc, result}) =>
665 end 674 end
666 | L.DSgn _ => ([], st) 675 | L.DSgn _ => ([], st)
667 676
668 | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) => 677 | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) =>
669 ([], St.bindFunctor st x n xa na str) 678 ([], St.bindFunctor st x n xa na str)
679
680 | L.DStr (x, n, _, (L.StrProj (str, x'), _)) =>
681 let
682 val (ds, {inner, outer}) = corifyStr (str, st)
683
684 val st = case St.lookupStrByNameOpt (x', inner) of
685 SOME st' => St.bindStr st x n st'
686 | NONE =>
687 let
688 val (x', n', str') = St.lookupFunctorByName (x', inner)
689 in
690 St.bindFunctor st x n x' n' str'
691 end
692 in
693 ([], st)
694 end
670 695
671 | L.DStr (x, n, _, str) => 696 | L.DStr (x, n, _, str) =>
672 let 697 let
673 val (ds, {inner, outer}) = corifyStr (str, st) 698 val (ds, {inner, outer}) = corifyStr (str, st)
674 val st = St.bindStr outer x n inner 699 val st = St.bindStr outer x n inner