summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjr.sml16
-rw-r--r--src/cjr_env.sig2
-rw-r--r--src/cjr_env.sml13
-rw-r--r--src/cjr_print.sml63
-rw-r--r--src/cjrize.sml43
5 files changed, 127 insertions, 10 deletions
diff --git a/src/cjr.sml b/src/cjr.sml
index 59f5cb2f..eb035e40 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -38,10 +38,24 @@ datatype typ' =
withtype typ = typ' located
+datatype patCon =
+ PConVar of int
+ | PConFfi of string * string
+
+datatype pat' =
+ PWild
+ | PVar of string
+ | PPrim of Prim.t
+ | PCon of patCon * pat option
+ | PRecord of (string * pat) list
+
+withtype pat = pat' located
+
datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
+ | ECon of int * exp option
| EFfi of string * string
| EFfiApp of string * string * exp list
| EApp of exp * exp
@@ -49,6 +63,8 @@ datatype exp' =
| ERecord of int * (string * exp) list
| EField of exp * string
+ | ECase of exp * (pat * exp) list * typ
+
| EWrite of exp
| ESeq of exp * exp
diff --git a/src/cjr_env.sig b/src/cjr_env.sig
index 5cd5cb32..7573c75e 100644
--- a/src/cjr_env.sig
+++ b/src/cjr_env.sig
@@ -39,6 +39,8 @@ signature CJR_ENV = sig
val pushDatatype : env -> string -> int -> (string * int * Cjr.typ option) list -> env
val lookupDatatype : env -> int -> string * (string * int * Cjr.typ option) list
+ val lookupConstructor : env -> int -> string * Cjr.typ option * int
+
val pushERel : env -> string -> Cjr.typ -> env
val lookupERel : env -> int -> string * Cjr.typ
val listERels : env -> (string * Cjr.typ) list
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 84f13f4d..f972a80e 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -39,6 +39,7 @@ exception UnboundStruct of int
type env = {
datatypes : (string * (string * int * typ option) list) IM.map,
+ constructors : (string * typ option * int) IM.map,
numRelE : int,
relE : (string * typ) list,
@@ -49,6 +50,7 @@ type env = {
val empty = {
datatypes = IM.empty,
+ constructors = IM.empty,
numRelE = 0,
relE = [],
@@ -59,6 +61,9 @@ val empty = {
fun pushDatatype (env : env) x n xncs =
{datatypes = IM.insert (#datatypes env, n, (x, xncs)),
+ constructors = foldl (fn ((x, n, to), constructors) =>
+ IM.insert (constructors, n, (x, to, n)))
+ (#constructors env) xncs,
numRelE = #numRelE env,
relE = #relE env,
@@ -71,8 +76,14 @@ fun lookupDatatype (env : env) n =
NONE => raise UnboundNamed n
| SOME x => x
+fun lookupConstructor (env : env) n =
+ case IM.find (#constructors env, n) of
+ NONE => raise UnboundNamed n
+ | SOME x => x
+
fun pushERel (env : env) x t =
{datatypes = #datatypes env,
+ constructors = #constructors env,
numRelE = #numRelE env + 1,
relE = (x, t) :: #relE env,
@@ -90,6 +101,7 @@ fun listERels (env : env) = #relE env
fun pushENamed (env : env) x n t =
{datatypes = #datatypes env,
+ constructors = #constructors env,
numRelE = #numRelE env,
relE = #relE env,
@@ -104,6 +116,7 @@ fun lookupENamed (env : env) n =
fun pushStruct (env : env) n xts =
{datatypes = #datatypes env,
+ constructors = #constructors env,
numRelE = #numRelE env,
relE = #relE env,
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index b0ea7214..61b2d6ce 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -90,6 +90,51 @@ fun p_exp' par env (e, _) =
EPrim p => Prim.p_t p
| ERel n => p_rel env n
| ENamed n => p_enamed env n
+ | ECon (n, eo) =>
+ let
+ val (x, _, dn) = E.lookupConstructor env n
+ val (dx, _) = E.lookupDatatype env dn
+ in
+ box [string "{(",
+ newline,
+ string "struct",
+ space,
+ string "__lwd_",
+ string dx,
+ string "_",
+ string (Int.toString dn),
+ space,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ string "lw_malloc(ctx, sizeof(struct __lwd_",
+ string dx,
+ string "_",
+ string (Int.toString dn),
+ string "));",
+ newline,
+ string "tmp->tag",
+ space,
+ string "=",
+ space,
+ string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
+ string ";",
+ newline,
+ case eo of
+ NONE => box []
+ | SOME e => box [string "tmp->data.",
+ string x,
+ space,
+ string "=",
+ space,
+ p_exp env e,
+ string ";",
+ newline],
+ string "tmp;",
+ newline,
+ string "})"]
+ end
| EFfi (m, x) => box [string "lw_", string m, string "_", string x]
| EFfiApp (m, x, es) => box [string "lw_",
@@ -121,7 +166,7 @@ fun p_exp' par env (e, _) =
space,
string ("__lws_" ^ Int.toString i),
space,
- string "__lw_tmp",
+ string "tmp",
space,
string "=",
space,
@@ -130,7 +175,7 @@ fun p_exp' par env (e, _) =
p_exp env e) xes,
string "};",
space,
- string "__lw_tmp;",
+ string "tmp;",
space,
string "})" ]
| EField (e, x) =>
@@ -138,6 +183,8 @@ fun p_exp' par env (e, _) =
string ".",
string x]
+ | ECase _ => raise Fail "CjrPrint ECase"
+
| EWrite e => box [string "(lw_write(ctx, ",
p_exp env e,
string "), lw_unit_v)"]
@@ -430,7 +477,7 @@ fun p_file env (ds, ps) =
string "__lws_",
string (Int.toString i),
space,
- string "__lw_tmp",
+ string "tmp",
space,
string "=",
space,
@@ -440,7 +487,7 @@ fun p_file env (ds, ps) =
space,
string "};",
newline,
- string "__lw_tmp;",
+ string "tmp;",
newline,
string "})"]
end
@@ -467,13 +514,13 @@ fun p_file env (ds, ps) =
space,
string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
space,
- string "*__lw_tmp = lw_malloc(ctx, sizeof(struct __lwd_",
+ string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_",
string x,
string "_",
string (Int.toString i),
string "));",
newline,
- string "__lw_tmp->tag",
+ string "tmp->tag",
space,
string "=",
space,
@@ -491,7 +538,7 @@ fun p_file env (ds, ps) =
newline,
case to of
NONE => box []
- | SOME t => box [string "__lw_tmp->data.",
+ | SOME t => box [string "tmp->data.",
string x',
space,
string "=",
@@ -499,7 +546,7 @@ fun p_file env (ds, ps) =
unurlify t,
string ";",
newline],
- string "__lw_tmp;",
+ string "tmp;",
newline,
string "})",
space,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index ac3563f0..7830e740 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -103,12 +103,38 @@ fun cifyTyp ((t, loc), sm) =
val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
+fun cifyPatCon pc =
+ case pc of
+ L.PConVar n => L'.PConVar n
+ | L.PConFfi mx => L'.PConFfi mx
+
+fun cifyPat (p, loc) =
+ case p of
+ L.PWild => (L'.PWild, loc)
+ | L.PVar x => (L'.PVar x, loc)
+ | L.PPrim p => (L'.PPrim p, loc)
+ | L.PCon (pc, po) => (L'.PCon (cifyPatCon pc, Option.map cifyPat po), loc)
+ | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, cifyPat p)) xps), loc)
+
fun cifyExp ((e, loc), sm) =
case e of
L.EPrim p => ((L'.EPrim p, loc), sm)
| L.ERel n => ((L'.ERel n, loc), sm)
| L.ENamed n => ((L'.ENamed n, loc), sm)
- | L.ECon _ => raise Fail "Cjrize ECon"
+ | L.ECon (n, eo) =>
+ let
+ val (eo, sm) =
+ case eo of
+ NONE => (NONE, sm)
+ | SOME e =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ (SOME e, sm)
+ end
+ in
+ ((L'.ECon (n, eo), loc), sm)
+ end
| L.EFfi mx => ((L'.EFfi mx, loc), sm)
| L.EFfiApp (m, x, es) =>
let
@@ -153,7 +179,20 @@ fun cifyExp ((e, loc), sm) =
((L'.EField (e, x), loc), sm)
end
- | L.ECase _ => raise Fail "Cjrize ECase"
+ | L.ECase (e, pes, t) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ val (pes, sm) = ListUtil.foldlMap
+ (fn ((p, e), sm) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ ((cifyPat p, e), sm)
+ end) sm pes
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.ECase (e, pes, t), loc), sm)
+ end
| L.EStrcat (e1, e2) =>
let
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-15 05:09:27 +0000