# HG changeset patch # User Adam Chlipala # Date 1217356124 14400 # Node ID a991431b77eb560241a5446341b3a1b02a044601 # Parent e52dfb1e6b19b9b7e01a15aa2a9f2cadfec7019e Start of unurlify for datatypes diff -r e52dfb1e6b19 -r a991431b77eb src/cjr.sml --- a/src/cjr.sml Tue Jul 29 13:50:53 2008 -0400 +++ b/src/cjr.sml Tue Jul 29 14:28:44 2008 -0400 @@ -33,7 +33,7 @@ TTop | TFun of typ * typ | TRecord of int - | TNamed of int + | TDatatype of int | TFfi of string * string withtype typ = typ' located diff -r e52dfb1e6b19 -r a991431b77eb src/cjr_env.sig --- a/src/cjr_env.sig Tue Jul 29 13:50:53 2008 -0400 +++ b/src/cjr_env.sig Tue Jul 29 14:28:44 2008 -0400 @@ -36,8 +36,8 @@ 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 -r e52dfb1e6b19 -r a991431b77eb src/cjr_env.sml --- a/src/cjr_env.sml Tue Jul 29 13:50:53 2008 -0400 +++ b/src/cjr_env.sml Tue Jul 29 14:28:44 2008 -0400 @@ -38,7 +38,7 @@ 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 @@ } val empty = { - namedT = IM.empty, + datatypes = IM.empty, numRelE = 0, relE = [], @@ -57,8 +57,8 @@ 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 @@ 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 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 @@ | 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 @@ 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 -r e52dfb1e6b19 -r a991431b77eb src/cjr_print.sml --- a/src/cjr_print.sml Tue Jul 29 13:50:53 2008 -0400 +++ b/src/cjr_print.sml Tue Jul 29 14:28:44 2008 -0400 @@ -53,7 +53,7 @@ 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 @@ 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 @@ 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 -r e52dfb1e6b19 -r a991431b77eb src/cjrize.sml --- a/src/cjrize.sml Tue Jul 29 13:50:53 2008 -0400 +++ b/src/cjrize.sml Tue Jul 29 14:28:44 2008 -0400 @@ -84,7 +84,7 @@ 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)