Mercurial > urweb
changeset 829:20fe00fd81da
Substring functions; fix a nasty MonoReduce pattern match substitution bug
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 30 May 2009 13:29:00 -0400 |
| parents | 14a6c0971d89 |
| children | d07980bf1444 |
| files | include/urweb.h lib/js/urweb.js lib/ur/basis.urs lib/ur/string.ur lib/ur/string.urs src/c/urweb.c src/jscomp.sml src/mono_reduce.sml src/settings.sml tests/substring.ur tests/substring.urp |
| diffstat | 11 files changed, 116 insertions(+), 14 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Sat May 30 09:59:10 2009 -0400 +++ b/include/urweb.h Sat May 30 13:29:00 2009 -0400 @@ -115,6 +115,10 @@ uw_Basis_char uw_Basis_strsub(uw_context, const char *, uw_Basis_int); uw_Basis_string uw_Basis_strsuffix(uw_context, const char *, uw_Basis_int); uw_Basis_string uw_Basis_strcat(uw_context, const char *, const char *); +uw_Basis_int *uw_Basis_strindex(uw_context, const char *, uw_Basis_char); +uw_Basis_string uw_Basis_strchr(uw_context, const char *, uw_Basis_char); +uw_Basis_string uw_Basis_substring(uw_context, const char *, uw_Basis_int, uw_Basis_int); + uw_Basis_string uw_strdup(uw_context, const char *); uw_Basis_string uw_maybe_strdup(uw_context, const char *); char *uw_memdup(uw_context, const char *, size_t);
--- a/lib/js/urweb.js Sat May 30 09:59:10 2009 -0400 +++ b/lib/js/urweb.js Sat May 30 13:29:00 2009 -0400 @@ -353,6 +353,23 @@ function sub(s, i) { return s[i]; } function suf(s, i) { return s.substring(i); } function slen(s) { return s.length; } +function sidx(s, ch) { + var r = s.indexOf(ch); + if (r == -1) + return null; + else + return r; +} +function schr(s, ch) { + var r = s.indexOf(ch); + if (r == -1) + return null; + else + return s.substring(r); +} +function ssub(s, start, len) { + return s.substring(start, start+len); +} function pi(s) { var r = parseInt(s);
--- a/lib/ur/basis.urs Sat May 30 09:59:10 2009 -0400 +++ b/lib/ur/basis.urs Sat May 30 13:29:00 2009 -0400 @@ -57,6 +57,9 @@ val strcat : string -> string -> string val strsub : string -> int -> char val strsuffix : string -> int -> string +val strchr : string -> char -> option string +val strindex : string -> char -> option int +val substring : string -> int -> int -> string class show val show : t ::: Type -> show t -> t -> string
--- a/lib/ur/string.ur Sat May 30 09:59:10 2009 -0400 +++ b/lib/ur/string.ur Sat May 30 13:29:00 2009 -0400 @@ -5,3 +5,14 @@ val sub = Basis.strsub val suffix = Basis.strsuffix + +val index = Basis.strindex +val atFirst = Basis.strchr + +fun substring s {Start = start, Len = len} = Basis.substring s start len + +fun split s ch = + case index s ch of + None => None + | Some i => Some (substring s {Start = 0, Len = i}, + substring s {Start = i + 1, Len = length s - i - 1})
--- a/lib/ur/string.urs Sat May 30 09:59:10 2009 -0400 +++ b/lib/ur/string.urs Sat May 30 13:29:00 2009 -0400 @@ -6,3 +6,10 @@ val sub : t -> int -> char val suffix : t -> int -> string + +val index : t -> char -> option int +val atFirst : t -> char -> option string + +val substring : t -> {Start : int, Len : int} -> string + +val split : t -> char -> option (string * string)
--- a/src/c/urweb.c Sat May 30 09:59:10 2009 -0400 +++ b/src/c/urweb.c Sat May 30 13:29:00 2009 -0400 @@ -1811,6 +1811,21 @@ 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 @@ 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;
--- a/src/jscomp.sml Sat May 30 09:59:10 2009 -0400 +++ b/src/jscomp.sml Sat May 30 13:29:00 2009 -0400 @@ -625,16 +625,17 @@ 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 #"\"" => "\\\"" | #"\\" => "\\\\"
--- a/src/mono_reduce.sml Sat May 30 09:59:10 2009 -0400 +++ b/src/mono_reduce.sml Sat May 30 13:29:00 2009 -0400 @@ -85,6 +85,11 @@ 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 @@ | 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 @@ | _ => 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
--- a/src/settings.sml Sat May 30 09:59:10 2009 -0400 +++ b/src/settings.sml Sat May 30 13:29:00 2009 -0400 @@ -153,7 +153,10 @@ ("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)