From f8d1a7fcf13f655200be366733c24233b5df7f9a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Sep 2008 11:53:30 -0400 Subject: 'read' type class --- src/cjr.sml | 1 + src/cjr_print.sml | 25 +++++++++++++++++++++++++ src/cjrize.sml | 7 +++++++ src/mono.sml | 1 + src/mono_print.sml | 3 +++ src/mono_reduce.sml | 1 + src/mono_util.sml | 6 ++++++ src/monoize.sml | 25 +++++++++++++++++++++++++ 8 files changed, 69 insertions(+) (limited to 'src') diff --git a/src/cjr.sml b/src/cjr.sml index d4c88246..74c4bca2 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -60,6 +60,7 @@ datatype exp' = | ERel of int | ENamed of int | ECon of datatype_kind * patCon * exp option + | ESome of typ * exp | EFfi of string * string | EFfiApp of string * string * exp list | EApp of exp * exp diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8ca7c09d..905c4e10 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -520,6 +520,31 @@ fun p_exp' par env (e, loc) = newline, string "})"] end + | ESome (t, e) => + (case #1 t of + TDatatype _ => p_exp' par env e + | TFfi ("Basis", "string") => p_exp' par env e + | _ => box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "lw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + p_exp' par env e, + string ";", + newline, + string "tmp;", + newline, + string "})"]) | EFfi (m, x) => box [string "lw_", string m, string "_", string x] | EError (e, t) => diff --git a/src/cjrize.sml b/src/cjrize.sml index a45cf02d..e137c6fd 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -211,6 +211,13 @@ fun cifyExp (eAll as (e, loc), sm) = in ((L'.ECon (dk, pc, eo), loc), sm) end + | L.ESome (t, e) => + let + val (t, sm) = cifyTyp (t, sm) + val (e, sm) = cifyExp (e, sm) + in + ((L'.ESome (t, e), loc), sm) + end | L.EFfi mx => ((L'.EFfi mx, loc), sm) | L.EFfiApp (m, x, es) => let diff --git a/src/mono.sml b/src/mono.sml index 3885c789..8c69443a 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -60,6 +60,7 @@ datatype exp' = | ERel of int | ENamed of int | ECon of datatype_kind * patCon * exp option + | ESome of typ * exp | EFfi of string * string | EFfiApp of string * string * exp list | EApp of exp * exp diff --git a/src/mono_print.sml b/src/mono_print.sml index da777a82..a2c55b6a 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -132,6 +132,9 @@ fun p_exp' par env (e, _) = | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc, space, p_exp' true env e]) + | ESome (_, e) => parenIf par (box [string "Some", + space, + p_exp' true env e]) | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] | EFfiApp (m, x, es) => box [string "FFI(", diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index c1972729..42f32256 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -45,6 +45,7 @@ fun impure (e, _) = | ERel _ => false | ENamed _ => false | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e) + | ESome (_, e) => impure e | EFfi _ => false | EFfiApp _ => false | EApp ((EFfi _, _), _) => false diff --git a/src/mono_util.sml b/src/mono_util.sml index b2fdff52..90ae3a4f 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -145,6 +145,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ECon (dk, n, SOME e'), loc)) + | ESome (t, e) => + S.bind2 (mft t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (ESome (t', e'), loc))) | EFfi _ => S.return2 eAll | EFfiApp (m, x, es) => S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es, diff --git a/src/monoize.sml b/src/monoize.sml index 802b12f8..e0f73802 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -85,6 +85,9 @@ fun monoType env = | 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) => + (L'.TFun ((L'.TFfi ("Basis", "string"), loc), + (L'.TOption (mt env dtmap t), loc)), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) @@ -490,6 +493,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "show_bool") => ((L'.EFfi ("Basis", "boolToString"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "read"), _), t) => + let + val t = monoType env t + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc), + (L'.ERel 0, loc)), loc), fm) + end + | L.EFfi ("Basis", "read_int") => + ((L'.EFfi ("Basis", "stringToInt"), loc), fm) + | L.EFfi ("Basis", "read_float") => + ((L'.EFfi ("Basis", "stringToFloat"), loc), fm) + | L.EFfi ("Basis", "read_string") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, (L'.TOption s, loc), + (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), fm) + end + | L.EFfi ("Basis", "read_bool") => + ((L'.EFfi ("Basis", "stringToBool"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "return"), _), t) => let val t = monoType env t -- cgit v1.2.3