summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sml25
-rw-r--r--src/monoize.sml89
-rw-r--r--src/urweb.grm19
-rw-r--r--src/urweb.lex5
4 files changed, 124 insertions, 14 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 5f430ccf..e0441425 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -614,19 +614,20 @@ fun p_exp' par env (e, loc) =
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,
diff --git a/src/monoize.sml b/src/monoize.sml
index 21798b0f..c00695d6 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -100,6 +100,18 @@ fun monoType env =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(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
diff --git a/src/urweb.grm b/src/urweb.grm
index 3511093c..183f9afd 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -158,6 +158,14 @@ fun sql_relop (oper, sqlexp1, sqlexp2, loc) =
(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 @@ fun tagIn bt =
| 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 @@ fun tagIn bt =
%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 @@ eexp : eapps (eapps)
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)
diff --git a/src/urweb.lex b/src/urweb.lex
index cd6cf66a..a3c34a16 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -274,6 +274,11 @@ notags = [^<{\n]+;
<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));
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 05:05:01 +0000