diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/c/urweb.c | 36 | ||||
| -rw-r--r-- | src/jscomp.sml | 21 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 17 | ||||
| -rw-r--r-- | src/settings.sml | 5 |
4 files changed, 65 insertions, 14 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c index cffbb57c..d8b606fd 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1811,6 +1811,21 @@ uw_Basis_int uw_Basis_strlen(uw_context ctx, uw_Basis_string s) { return strlen(s); } +uw_Basis_string uw_Basis_strchr(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { + return strchr(s, ch); +} + +uw_Basis_int *uw_Basis_strindex(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { + uw_Basis_string r = strchr(s, ch); + if (r == NULL) + return NULL; + else { + uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int)); + *nr = r - s; + return nr; + } +} + uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) { int len = uw_Basis_strlen(ctx, s1) + uw_Basis_strlen(ctx, s2) + 1; char *s; @@ -1826,6 +1841,27 @@ uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_str return s; } +uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_int start, uw_Basis_int len) { + size_t full_len = uw_Basis_strlen(ctx, s); + + if (start < 0) + uw_error(ctx, FATAL, "substring: Negative start index"); + if (len < 0) + uw_error(ctx, FATAL, "substring: Negative length"); + if (start + len > full_len) + uw_error(ctx, FATAL, "substring: Start index plus length is too large"); + + if (start + len == full_len) + return &s[start]; + else { + uw_Basis_string r = uw_malloc(ctx, len+1); + memcpy(r, s, len); + r[len] = 0; + return r; + } + +} + uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) { int len = uw_Basis_strlen(ctx, s1) + 1; char *s; diff --git a/src/jscomp.sml b/src/jscomp.sml index 3edb670f..e162aa7f 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -625,16 +625,17 @@ fun process file = str ":", succ, str ")"] - | PSome (t, p) => strcat (str ("(d" ^ Int.toString depth ^ "?") - :: (if isNullable t then - [str ("d" ^ Int.toString depth - ^ "=d" ^ Int.toString depth ^ ".v")] - else - []) - @ [jsPat depth inner p succ fail, - str ":", - fail, - str ")"]) + | PSome (t, p) => strcat [str ("(d" ^ Int.toString depth ^ "?(d" ^ Int.toString (depth+1) + ^ "=d" ^ Int.toString depth + ^ (if isNullable t then + ".v" + else + "") + ^ ","), + jsPat (depth+1) inner p succ fail, + str "):", + fail, + str ")"] val jsifyString = String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 985f76a2..1ea3df36 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -85,6 +85,11 @@ fun impure (e, _) = val liftExpInExp = Monoize.liftExpInExp +fun multiLift n e = + case n of + 0 => e + | _ => multiLift (n - 1) (liftExpInExp 0 e) + val subExpInExp' = U.Exp.mapB {typ = fn t => t, exp = fn (xn, rep) => fn e => @@ -419,11 +424,16 @@ fun reduce file = | Maybe => push () | Yes subs => let - val body = foldr (fn (e, body) => subExpInExp (0, e) body) body subs + val (body, remaining) = + foldl (fn (e, (body, remaining)) => + (subExpInExp (0, multiLift remaining e) body, remaining - 1)) + (body, length subs - 1) subs val r = reduceExp env body in + (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*) (*Print.prefaces "ECase" - [("body", MonoPrint.p_exp env' body), + [("old", MonoPrint.p_exp env body), + ("body", MonoPrint.p_exp env body), ("r", MonoPrint.p_exp env r)];*) #1 r end @@ -533,7 +543,8 @@ fun reduce file = | _ => e in - (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) + (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), + ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) r end diff --git a/src/settings.sml b/src/settings.sml index fa162660..75302cb9 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -153,7 +153,10 @@ val jsFuncsBase = basisM [("alert", "alert"), ("boolToString", "ts"), ("strsub", "sub"), ("strsuffix", "suf"), - ("strlen", "slen")] + ("strlen", "slen"), + ("strindex", "sidx"), + ("strchr", "schr"), + ("substring", "ssub")] val jsFuncs = ref jsFuncsBase fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) |