Mercurial > urweb
comparison src/cjr_print.sml @ 1663:0577be31a435
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 |