Mercurial > urweb

changeset 389:acaf9d19fbb7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
num working for int
author Adam Chlipala <adamc@hcoop.net>
date Tue, 21 Oct 2008 10:34:07 -0400
parents 2e93d18daf44
children 519366a76603
files lib/basis.urs src/cjr_print.sml src/monoize.sml src/urweb.grm src/urweb.lex tests/num.ur tests/num.urp
diffstat 7 files changed, 139 insertions(+), 14 deletions(-) [+]
line wrap: on
line diff
--- a/lib/basis.urs	Tue Oct 21 09:52:52 2008 -0400
+++ b/lib/basis.urs	Tue Oct 21 10:34:07 2008 -0400
@@ -18,6 +18,15 @@
 val eq_string : eq string
 val eq_bool : eq bool
 
+class num
+val neg : t ::: Type -> num t -> t -> t
+val plus : t ::: Type -> num t -> t -> t -> t
+val minus : t ::: Type -> num t -> t -> t -> t
+val times : t ::: Type -> num t -> t -> t -> t
+val div : t ::: Type -> num t -> t -> t -> t
+val mod : t ::: Type -> num t -> t -> t -> t
+val num_int : num int
+
 
 (** String operations *)
 
--- a/src/cjr_print.sml	Tue Oct 21 09:52:52 2008 -0400
+++ b/src/cjr_print.sml	Tue Oct 21 10:34:07 2008 -0400
@@ -614,19 +614,20 @@
                           space,
                           p_exp' true env e1])
 
-      | EBinop ("!strcmp", e1, e2) =>
-        box [string "!strcmp(",
-             p_exp env e1,
-             string ",",
-             space,
-             p_exp env e2,
-             string ")"]
       | EBinop (s, e1, e2) =>
-        parenIf par (box [p_exp' true env e1,
-                          space,
-                          string s,
-                          space,
-                          p_exp' true env e2])
+        if Char.isAlpha (String.sub (s, size s - 1)) then
+            box [string s,
+                 p_exp env e1,
+                 string ",",
+                 space,
+                 p_exp env e2,
+                 string ")"]
+        else
+            parenIf par (box [p_exp' true env e1,
+                              space,
+                              string s,
+                              space,
+                              p_exp' true env e2])
 
       | ERecord (i, xes) => box [string "({",
                                  space,
--- a/src/monoize.sml	Tue Oct 21 09:52:52 2008 -0400
+++ b/src/monoize.sml	Tue Oct 21 10:34:07 2008 -0400
@@ -100,6 +100,18 @@
                     in
                         (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)
                     end
+                  | L.CApp ((L.CFfi ("Basis", "num"), _), t) =>
+                    let
+                        val t = mt env dtmap t
+                    in
+                        (L'.TRecord [("Neg", (L'.TFun (t, t), loc)),
+                                     ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                                     ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                                     ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                                     ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                                     ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))],
+                         loc)
+                    end
                   | L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
                     (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
                   | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
@@ -469,6 +481,21 @@
             (E.errorAt loc "Unsupported expression";
              Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
              (dummyExp, fm))
+
+        fun numTy t =
+            (L'.TRecord [("Neg", (L'.TFun (t, t), loc)),
+                         ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                         ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                         ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                         ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                         ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc)
+        fun numEx (t, neg, plus, minus, times, dv, md) =
+            ((L'.ERecord [("Neg", neg, (L'.TFun (t, t), loc)),
+                          ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                          ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                          ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                          ("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
+                          ("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm)
     in
         case e of
             L.EPrim p => ((L'.EPrim p, loc), fm)
@@ -545,6 +572,68 @@
                                  (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
              fm)
 
+          | L.ECApp ((L.EFfi ("Basis", "neg"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc),
+                           (L'.EField ((L'.ERel 0, loc), "Neg"), loc)), loc), fm)
+            end
+          | L.ECApp ((L.EFfi ("Basis", "plus"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
+                           (L'.EField ((L'.ERel 0, loc), "Plus"), loc)), loc), fm)
+            end
+          | L.ECApp ((L.EFfi ("Basis", "minus"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
+                           (L'.EField ((L'.ERel 0, loc), "Minus"), loc)), loc), fm)
+            end
+          | L.ECApp ((L.EFfi ("Basis", "times"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
+                           (L'.EField ((L'.ERel 0, loc), "Times"), loc)), loc), fm)
+            end
+          | L.ECApp ((L.EFfi ("Basis", "div"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
+                           (L'.EField ((L'.ERel 0, loc), "Div"), loc)), loc), fm)
+            end
+          | L.ECApp ((L.EFfi ("Basis", "mod"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
+                           (L'.EField ((L'.ERel 0, loc), "Mod"), loc)), loc), fm)
+            end
+          | L.EFfi ("Basis", "num_int") =>
+            let
+                fun intBin s =
+                    (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
+                              (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc),
+                              (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
+                                        (L'.TFfi ("Basis", "int"), loc),
+                                        (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
+            in
+                numEx ((L'.TFfi ("Basis", "int"), loc),
+                       (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
+                                 (L'.TFfi ("Basis", "int"), loc),
+                                 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
+                       intBin "+",
+                       intBin "-",
+                       intBin "*",
+                       intBin "/",
+                       intBin "%")
+            end
+                       
           | L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
             let
                 val t = monoType env t
--- a/src/urweb.grm	Tue Oct 21 09:52:52 2008 -0400
+++ b/src/urweb.grm	Tue Oct 21 10:34:07 2008 -0400
@@ -158,6 +158,14 @@
         (EApp (e, sqlexp2), loc)
     end
 
+fun native_unop (oper, e1, loc) =
+    let
+        val e = (EVar (["Basis"], oper), loc)
+        val e = (EApp (e, (EWild, loc)), loc)
+    in
+        (EApp (e, e1), loc)
+    end
+
 fun native_op (oper, e1, e2, loc) =
     let
         val e = (EVar (["Basis"], oper), loc)
@@ -183,7 +191,7 @@
  | SYMBOL of string | CSYMBOL of string
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
  | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
- | DIVIDE | DOTDOTDOT
+ | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD
  | CON | LTYPE | VAL | REC | AND | FUN | FOLD | UNIT | KUNIT | CLASS
  | DATATYPE | OF
  | TYPE | NAME
@@ -335,7 +343,8 @@
 %right ARROW
 %left WITH
 %right PLUSPLUS MINUSMINUS
-%right STAR
+%left PLUS MINUS
+%left STAR DIVIDE MOD
 %left NOT
 %nonassoc TWIDDLE
 %nonassoc DOLLAR
@@ -682,6 +691,12 @@
                                          end)
        | eexp EQ eexp                   (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
        | eexp NE eexp                   (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
+       | MINUS eterm                    (native_unop ("neg", eterm, s (MINUSleft, etermright)))
+       | eexp PLUS eexp                 (native_op ("plus", eexp1, eexp2, s (eexp1left, eexp2right)))
+       | eexp MINUS eexp                (native_op ("minus", eexp1, eexp2, s (eexp1left, eexp2right)))
+       | eterm STAR eexp                (native_op ("times", eterm, eexp, s (etermleft, eexpright)))
+       | eexp DIVIDE eexp               (native_op ("div", eexp1, eexp2, s (eexp1left, eexp2right)))
+       | eexp MOD eexp                  (native_op ("mod", eexp1, eexp2, s (eexp1left, eexp2right)))
        | eexp WITH cterm EQ eexp        (EWith (eexp1, cterm, eexp2), s (eexp1left, eexp2right))
 
 eargs  : earg                           (earg)
--- a/src/urweb.lex	Tue Oct 21 09:52:52 2008 -0400
+++ b/src/urweb.lex	Tue Oct 21 10:34:07 2008 -0400
@@ -274,6 +274,11 @@
 <INITIAL> "<-"        => (Tokens.LARROW (pos yypos, pos yypos + size yytext));
 <INITIAL> ";"         => (Tokens.SEMI (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "+"         => (Tokens.PLUS (pos yypos, pos yypos + size yytext));
+<INITIAL> "-"         => (Tokens.MINUS (pos yypos, pos yypos + size yytext));
+<INITIAL> "/"         => (Tokens.DIVIDE (yypos, yypos + size yytext));
+<INITIAL> "%"         => (Tokens.MOD (pos yypos, pos yypos + size yytext));
+
 <INITIAL> "con"       => (Tokens.CON (pos yypos, pos yypos + size yytext));
 <INITIAL> "type"      => (Tokens.LTYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "datatype"  => (Tokens.DATATYPE (pos yypos, pos yypos + size yytext));
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/num.ur	Tue Oct 21 10:34:07 2008 -0400
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <xml><body>
+  {txt _ (-1)}, {txt _ (1 + 1)}, {txt _ (9 - 3)}, {txt _ (9 * 3)}, {txt _ (9 / 3)}, {txt _ (9 % 3)}
+</body></xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/num.urp	Tue Oct 21 10:34:07 2008 -0400
@@ -0,0 +1,3 @@
+debug
+
+num