Mercurial > urweb
changeset 389:acaf9d19fbb7
num working for int
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 21 Oct 2008 10:34:07 -0400 (2008-10-21) |
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));