Mercurial > urweb

comparison src/cjr_print.sml @ 1663:0577be31a435

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First part of changes to avoid depending on C function call argument order of evaluation (omitting normal Ur function calls, so far)
author Adam Chlipala <adam@chlipala.net>
date Sat, 07 Jan 2012 15:56:22 -0500
parents 3e7c7e200713
children a12186d99e4f
comparison
equal deleted inserted replaced
1662:edf86cef0dba 1663:0577be31a435
488 fun p_sql_type t = string (Settings.p_sql_ctype t) 488 fun p_sql_type t = string (Settings.p_sql_ctype t)
489 489
490 fun getPargs (e, _) = 490 fun getPargs (e, _) =
491 case e of 491 case e of
492 EPrim (Prim.String _) => [] 492 EPrim (Prim.String _) => []
493 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2 493 | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => getPargs e1 @ getPargs e2
494 494
495 | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)] 495 | EFfiApp ("Basis", "sqlifyInt", [(e, _)]) => [(e, Int)]
496 | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)] 496 | EFfiApp ("Basis", "sqlifyFloat", [(e, _)]) => [(e, Float)]
497 | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] 497 | EFfiApp ("Basis", "sqlifyString", [(e, _)]) => [(e, String)]
498 | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] 498 | EFfiApp ("Basis", "sqlifyBool", [(e, _)]) => [(e, Bool)]
499 | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] 499 | EFfiApp ("Basis", "sqlifyTime", [(e, _)]) => [(e, Time)]
500 | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)] 500 | EFfiApp ("Basis", "sqlifyBlob", [(e, _)]) => [(e, Blob)]
501 | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)] 501 | EFfiApp ("Basis", "sqlifyChannel", [(e, _)]) => [(e, Channel)]
502 | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)] 502 | EFfiApp ("Basis", "sqlifyClient", [(e, _)]) => [(e, Client)]
503 503
504 | ECase (e, 504 | ECase (e,
505 [((PNone _, _), 505 [((PNone _, _),
506 (EPrim (Prim.String "NULL"), _)), 506 (EPrim (Prim.String "NULL"), _)),
507 ((PSome (_, (PVar _, _)), _), 507 ((PSome (_, (PVar _, _)), _),
508 (EFfiApp (m, x, [(ERel 0, _)]), _))], 508 (EFfiApp (m, x, [((ERel 0, _), _)]), _))],
509 _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e)) 509 {disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e))
510 510
511 | ECase (e, 511 | ECase (e,
512 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), 512 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
513 (EPrim (Prim.String "TRUE"), _)), 513 (EPrim (Prim.String "TRUE"), _)),
514 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), 514 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
1440 | ESetval {seq = e1, count = e2} => potentiallyFancy e1 orelse potentiallyFancy e2 1440 | ESetval {seq = e1, count = e2} => potentiallyFancy e1 orelse potentiallyFancy e2
1441 | EUnurlify _ => true 1441 | EUnurlify _ => true
1442 1442
1443 val self = ref (NONE : int option) 1443 val self = ref (NONE : int option)
1444 1444
1445 fun p_exp' par tail env (e, loc) = 1445 (* The crucial thing to do here is assign arguments to local variables, to enforce order of evaluation.
1446 * Otherwise, we are at the mercy of C's undefined order of function argument evaluation. *)
1447 fun pFuncall env (m, x, es, extra) =
1448 case es of
1449 [] => box [string "uw_",
1450 p_ident m,
1451 string "_",
1452 p_ident x,
1453 string "(ctx",
1454 case extra of
1455 NONE => box []
1456 | SOME extra => box [string ",",
1457 space,
1458 string extra],
1459 string ")"]
1460 | [(e, _)] => box [string "uw_",
1461 p_ident m,
1462 string "_",
1463 p_ident x,
1464 string "(ctx,",
1465 space,
1466 p_exp' false false env e,
1467 case extra of
1468 NONE => box []
1469 | SOME extra => box [string ",",
1470 space,
1471 string extra],
1472 string ")"]
1473 | _ => box [string "({",
1474 newline,
1475 p_list_sepi (box []) (fn i => fn (e, t) =>
1476 box [p_typ env t,
1477 space,
1478 string "arg",
1479 string (Int.toString i),
1480 space,
1481 string "=",
1482 space,
1483 p_exp' false false env e,
1484 string ";",
1485 newline]) es,
1486 string "uw_",
1487 p_ident m,
1488 string "_",
1489 p_ident x,
1490 string "(ctx, ",
1491 p_list_sepi (box [string ",", space]) (fn i => fn _ => box [string "arg", string (Int.toString i)]) es,
1492 case extra of
1493 NONE => box []
1494 | SOME extra => box [string ",",
1495 space,
1496 string extra],
1497 string ");",
1498 newline,
1499 string "})"]
1500
1501 and p_exp' par tail env (e, loc) =
1446 case e of 1502 case e of
1447 EPrim p => Prim.p_t_GCC p 1503 EPrim p => Prim.p_t_GCC p
1448 | ERel n => p_rel env n 1504 | ERel n => p_rel env n
1449 | ENamed n => p_enamed env n 1505 | ENamed n => p_enamed env n
1450 | ECon (Enum, pc, _) => p_patCon env pc 1506 | ECon (Enum, pc, _) => p_patCon env pc
1570 newline, 1626 newline,
1571 string "})"] 1627 string "})"]
1572 | EReturnBlob {blob, mimeType, t} => 1628 | EReturnBlob {blob, mimeType, t} =>
1573 box [string "({", 1629 box [string "({",
1574 newline, 1630 newline,
1631 string "uw_Basis_blob",
1632 space,
1633 string "blob",
1634 space,
1635 string "=",
1636 space,
1637 p_exp' false false env blob,
1638 string ";",
1639 newline,
1640 string "uw_Basis_string",
1641 space,
1642 string "mimeType",
1643 space,
1644 string "=",
1645 space,
1646 p_exp' false false env mimeType,
1647 string ";",
1648 newline,
1575 p_typ env t, 1649 p_typ env t,
1576 space, 1650 space,
1577 string "tmp;", 1651 string "tmp;",
1578 newline, 1652 newline,
1579 string "uw_return_blob(ctx, ", 1653 string "uw_return_blob(ctx, blob, mimeType);",
1580 p_exp' false false env blob,
1581 string ", ",
1582 p_exp' false false env mimeType,
1583 string ");",
1584 newline, 1654 newline,
1585 string "tmp;", 1655 string "tmp;",
1586 newline, 1656 newline,
1587 string "})"] 1657 string "})"]
1588 | ERedirect (e, t) => 1658 | ERedirect (e, t) =>
1602 | EApp ((EError (e, (TFun (_, ran), _)), loc), _) => 1672 | EApp ((EError (e, (TFun (_, ran), _)), loc), _) =>
1603 p_exp' false false env (EError (e, ran), loc) 1673 p_exp' false false env (EError (e, ran), loc)
1604 | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) => 1674 | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
1605 p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc) 1675 p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
1606 1676
1607 | EFfiApp ("Basis", "strcat", [e1, e2]) => 1677 | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
1608 let 1678 let
1609 fun flatten e = 1679 fun flatten e =
1610 case #1 e of 1680 case #1 e of
1611 EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2 1681 EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => flatten e1 @ flatten e2
1612 | _ => [e] 1682 | _ => [e]
1683
1684 val es = flatten e1 @ flatten e2
1685 val t = (TFfi ("Basis", "string"), loc)
1686 val es = map (fn e => (e, t)) es
1613 in 1687 in
1614 case flatten e1 @ flatten e2 of 1688 case es of
1615 [e1, e2] => box [string "uw_Basis_strcat(ctx, ", 1689 [_, _] => pFuncall env ("Basis", "strcat", es, NONE)
1616 p_exp' false false env e1, 1690 | _ => pFuncall env ("Basis", "mstrcat", es, SOME "NULL")
1617 string ",",
1618 p_exp' false false env e2,
1619 string ")"]
1620 | es => box [string "uw_Basis_mstrcat(ctx, ",
1621 p_list (p_exp' false false env) es,
1622 string ", NULL)"]
1623 end 1691 end
1624 1692
1625 | EFfiApp (m, x, []) => box [string "uw_", 1693 | EFfiApp (m, x, es) => pFuncall env (m, x, es, NONE)
1626 p_ident m,
1627 string "_",
1628 p_ident x,
1629 string "(ctx)"]
1630
1631 | EFfiApp (m, x, es) => box [string "uw_",
1632 p_ident m,
1633 string "_",
1634 p_ident x,
1635 string "(ctx, ",
1636 p_list (p_exp' false false env) es,
1637 string ")"]
1638 | EApp (f, args) => 1694 | EApp (f, args) =>
1639 let 1695 let
1640 fun default () = parenIf par (box [p_exp' true false env f, 1696 fun default () = parenIf par (box [p_exp' true false env f,
1641 string "(ctx,", 1697 string "(ctx,",
1642 space, 1698 space,
3034 3090
3035 fun expDb (e, _) = 3091 fun expDb (e, _) =
3036 case e of 3092 case e of
3037 ECon (_, _, SOME e) => expDb e 3093 ECon (_, _, SOME e) => expDb e
3038 | ESome (_, e) => expDb e 3094 | ESome (_, e) => expDb e
3039 | EFfiApp (_, _, es) => List.exists expDb es 3095 | EFfiApp (_, _, es) => List.exists (expDb o #1) es
3040 | EApp (e, es) => expDb e orelse List.exists expDb es 3096 | EApp (e, es) => expDb e orelse List.exists expDb es
3041 | EUnop (_, e) => expDb e 3097 | EUnop (_, e) => expDb e
3042 | EBinop (_, e1, e2) => expDb e1 orelse expDb e2 3098 | EBinop (_, e1, e2) => expDb e1 orelse expDb e2
3043 | ERecord (_, xes) => List.exists (expDb o #2) xes 3099 | ERecord (_, xes) => List.exists (expDb o #2) xes
3044 | EField (e, _) => expDb e 3100 | EField (e, _) => expDb e