Mercurial > urweb

comparison src/elaborate.sml @ 1989:210fb3dfc483

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Some more nested functor bug-fixing, including generating fresh internal names at applications; still need to debug issues with datatype constructors
author Adam Chlipala <adam@chlipala.net>
date Thu, 20 Feb 2014 10:27:15 -0500
parents 2c075e875a47
children 7db8356caef5
comparison
equal deleted inserted replaced
1988:abb6981a2c4c 1989:210fb3dfc483
4293 ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) 4293 ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs))
4294 end) 4294 end)
4295 4295
4296 (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) 4296 (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
4297 in 4297 in
4298 (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) 4298 (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll),
4299 ("d'", p_list_sep PD.newline (ElabPrint.p_decl env) (#1 r))];*)
4299 r 4300 r
4300 end 4301 end
4301 4302
4302 and elabStr (env, denv) (str, loc) = 4303 and elabStr (env, denv) (str, loc) =
4303 case str of 4304 case str of
4452 val (ran', gs) = elabSgn (env', denv') ran 4453 val (ran', gs) = elabSgn (env', denv') ran
4453 in 4454 in
4454 subSgn env' loc actual ran'; 4455 subSgn env' loc actual ran';
4455 (ran', gs) 4456 (ran', gs)
4456 end 4457 end
4458
4459 (* Later compiler phases are simplified by alpha-varying
4460 * the functor formal argument here, if the same name
4461 * will be defined independently in the functor body. *)
4462 fun ensureUnused m =
4463 case E.projectStr env' {sgn = actual, str = (L'.StrVar 0, loc), field = m} of
4464 NONE => m
4465 | SOME _ => ensureUnused ("?" ^ m)
4466
4467 val m = ensureUnused m
4457 in 4468 in
4458 ((L'.StrFun (m, n, dom', formal, str'), loc), 4469 ((L'.StrFun (m, n, dom', formal, str'), loc),
4459 (L'.SgnFun (m, n, dom', formal), loc), 4470 (L'.SgnFun (m, n, dom', formal), loc),
4460 enD gs1 @ gs2 @ enD gs3) 4471 enD gs1 @ gs2 @ enD gs3)
4461 end 4472 end
4489 * maintain the invariant, but the code below, to extend a functor 4500 * maintain the invariant, but the code below, to extend a functor
4490 * body with a binding for the functor argument, wasn't written 4501 * body with a binding for the functor argument, wasn't written
4491 * with the invariant in mind. Luckily for us, references to 4502 * with the invariant in mind. Luckily for us, references to
4492 * an identifier later within a signature work by globally 4503 * an identifier later within a signature work by globally
4493 * unique index, so we just need to change the string name in the 4504 * unique index, so we just need to change the string name in the
4494 * new declaration. *) 4505 * new declaration.
4495 val m = 4506 *
4507 * ~~~ A few days later.... ~~~
4508 * This is trickier than I thought! We might need to add
4509 * arbitarily many question marks before the module name to
4510 * avoid a clash, since some other code might depend on
4511 * question-mark identifiers generated previously by this
4512 * very code fragment. *)
4513 fun mungeName m =
4496 if List.exists (fn (L'.SgiStr (x, _, _), _) => x = m 4514 if List.exists (fn (L'.SgiStr (x, _, _), _) => x = m
4497 | _ => false) sgis then 4515 | _ => false) sgis then
4498 "?" ^ m 4516 mungeName ("?" ^ m)
4499 else 4517 else
4500 m 4518 m
4519
4520 val m = mungeName m
4501 in 4521 in
4502 ((L'.StrApp (str1', str2'), loc), 4522 ((L'.StrApp (str1', str2'), loc),
4503 (L'.SgnConst ((L'.SgiStr (m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc), 4523 (L'.SgnConst ((L'.SgiStr (m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc),
4504 gs1 @ gs2) 4524 gs1 @ gs2)
4505 end 4525 end