From 6855e4766fa8d07e2f3e3cd468de6c58fed0c903 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 29 Jul 2008 14:28:44 -0400 Subject: Start of unurlify for datatypes --- src/cjr.sml | 2 +- src/cjr_env.sig | 4 ++-- src/cjr_env.sml | 24 +++++++++++----------- src/cjr_print.sml | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++---- src/cjrize.sml | 2 +- 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) -- cgit v1.2.3