summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_env.sig4
-rw-r--r--src/cjr_env.sml24
-rw-r--r--src/cjr_print.sml60
-rw-r--r--src/cjrize.sml2
5 files changed, 72 insertions, 20 deletions
diff --git a/src/cjr.sml b/src/cjr.sml
index 621ccf45..b5174255 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -33,7 +33,7 @@ datatype typ' =
TTop
| TFun of typ * typ
| TRecord of int
- | TNamed of int
+ | TDatatype of int
| TFfi of string * string
withtype typ = typ' located
diff --git a/src/cjr_env.sig b/src/cjr_env.sig
index 36c3d682..5cd5cb32 100644
--- a/src/cjr_env.sig
+++ b/src/cjr_env.sig
@@ -36,8 +36,8 @@ signature CJR_ENV = sig
exception UnboundF of int
exception UnboundStruct of int
- val pushTNamed : env -> string -> int -> Cjr.typ option -> env
- val lookupTNamed : env -> int -> string * Cjr.typ option
+ val pushDatatype : env -> string -> int -> (string * int * Cjr.typ option) list -> env
+ val lookupDatatype : env -> int -> string * (string * int * Cjr.typ option) list
val pushERel : env -> string -> Cjr.typ -> env
val lookupERel : env -> int -> string * Cjr.typ
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 0d34b98f..88d7972f 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -38,7 +38,7 @@ exception UnboundF of int
exception UnboundStruct of int
type env = {
- namedT : (string * typ option) IM.map,
+ datatypes : (string * (string * int * typ option) list) IM.map,
numRelE : int,
relE : (string * typ) list,
@@ -48,7 +48,7 @@ type env = {
}
val empty = {
- namedT = IM.empty,
+ datatypes = IM.empty,
numRelE = 0,
relE = [],
@@ -57,8 +57,8 @@ val empty = {
structs = IM.empty
}
-fun pushTNamed (env : env) x n co =
- {namedT = IM.insert (#namedT env, n, (x, co)),
+fun pushDatatype (env : env) x n xncs =
+ {datatypes = IM.insert (#datatypes env, n, (x, xncs)),
numRelE = #numRelE env,
relE = #relE env,
@@ -66,13 +66,13 @@ fun pushTNamed (env : env) x n co =
structs = #structs env}
-fun lookupTNamed (env : env) n =
- case IM.find (#namedT env, n) of
+fun lookupDatatype (env : env) n =
+ case IM.find (#datatypes env, n) of
NONE => raise UnboundNamed n
| SOME x => x
fun pushERel (env : env) x t =
- {namedT = #namedT env,
+ {datatypes = #datatypes env,
numRelE = #numRelE env + 1,
relE = (x, t) :: #relE env,
@@ -89,7 +89,7 @@ fun countERels (env : env) = #numRelE env
fun listERels (env : env) = #relE env
fun pushENamed (env : env) x n t =
- {namedT = #namedT env,
+ {datatypes = #datatypes env,
numRelE = #numRelE env,
relE = #relE env,
@@ -103,7 +103,7 @@ fun lookupENamed (env : env) n =
| SOME x => x
fun pushStruct (env : env) n xts =
- {namedT = #namedT env,
+ {datatypes = #datatypes env,
numRelE = #numRelE env,
relE = #relE env,
@@ -120,10 +120,10 @@ fun declBinds env (d, loc) =
case d of
DDatatype (x, n, xncs) =>
let
- val env = pushTNamed env x n NONE
+ val env = pushDatatype env x n xncs
in
- foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TNamed n, loc)
- | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc))
+ foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype n, loc)
+ | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype n, loc)), loc))
env xncs
end
| DStruct (n, xts) => pushStruct env n xts
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index c9dfc481..1aab8f02 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -53,7 +53,7 @@ structure CM = BinaryMapFn(struct
val debug = ref false
-val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
+val dummyTyp = (TDatatype 0, ErrorMsg.dummySpan)
fun p_typ' par env (t, loc) =
case t of
@@ -69,11 +69,11 @@ fun p_typ' par env (t, loc) =
space,
string "__lws_",
string (Int.toString i)]
- | TNamed n =>
+ | TDatatype n =>
(box [string "struct",
space,
- string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n ^ "*")]
- handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
+ string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
+ handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
| TFfi (m, x) => box [string "lw_", string m, string "_", string x]
and p_typ env = p_typ' false env
@@ -445,6 +445,58 @@ fun p_file env (ds, ps) =
string "})"]
end
+ | TDatatype i =>
+ let
+ val (x, xncs) = E.lookupDatatype env i
+
+ fun doEm xncs =
+ case xncs of
+ [] => string "Uh oh"
+ | (x, n, to) :: rest =>
+ box [string "(!strcmp(request, \"",
+ string x,
+ string "\") ? ({",
+ newline,
+ string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
+ space,
+ string "__lw_tmp;",
+ newline,
+ string "__lw_tmp.tag",
+ space,
+ string "=",
+ space,
+ string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
+ string ";",
+ newline,
+ string "request",
+ space,
+ string "+=",
+ space,
+ string (Int.toString (size x)),
+ string ";",
+ newline,
+ case to of
+ NONE => box []
+ | SOME t => box [string "__lw_tmp.data.",
+ string x,
+ space,
+ string "=",
+ space,
+ unurlify t,
+ string ";",
+ newline],
+ string "__lw_tmp;",
+ newline,
+ string "})",
+ space,
+ string ":",
+ space,
+ doEm rest,
+ string ")"]
+ in
+ doEm xncs
+ end
+
| _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
space)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index c60ff75f..cf32e414 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -84,7 +84,7 @@ fun cifyTyp ((t, loc), sm) =
in
((L'.TRecord si, loc), sm)
end
- | L.TNamed n => ((L'.TNamed n, loc), sm)
+ | L.TNamed n => ((L'.TDatatype n, loc), sm)
| L.TFfi mx => ((L'.TFfi mx, loc), sm)
val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 17:10:31 +0000