From 509e9564fe6655fe79e70decf2a61a6a6d3761ba Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 18 Dec 2014 07:48:37 -0500 Subject: Fix XML syntax for closing tags --- src/monoize.sml | 4 +++- tests/nestedInput.ur | 10 ++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 tests/nestedInput.ur diff --git a/src/monoize.sml b/src/monoize.sml index 6563da8b..392a05c1 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3447,6 +3447,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE => tagStart | SOME extra => (L'.EStrcat (tagStart, extra), loc) + val firstWord = Substring.string o #1 o Substring.splitl (fn ch => not (Char.isSpace ch)) o Substring.full + fun normal () = let val (xml, fm) = monoExp (env, st, fm) xml @@ -3457,7 +3459,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc), (L'.EStrcat (xml, - strH (String.concat [""])), loc)), + strH (String.concat [""])), loc)), loc), fm) end diff --git a/tests/nestedInput.ur b/tests/nestedInput.ur new file mode 100644 index 00000000..19a73e15 --- /dev/null +++ b/tests/nestedInput.ur @@ -0,0 +1,10 @@ +fun main () : transaction page = + let + fun handler _ = return + in + return + + + end -- cgit v1.2.3 From e8f0606212506de059a2ac3730d0a01ecb977c70 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2014 13:20:11 -0500 Subject: Compatibility fix in header file --- include/urweb/request.h | 1 + 1 file changed, 1 insertion(+) diff --git a/include/urweb/request.h b/include/urweb/request.h index 0b19e7f4..a15df10c 100644 --- a/include/urweb/request.h +++ b/include/urweb/request.h @@ -2,6 +2,7 @@ #define REQUEST_H #include +#include #include "types.h" -- cgit v1.2.3 From 6e9e97242c177c7fbc71678e2b495687ace312f0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 11:23:27 -0500 Subject: Another try at a proper fix for constraint matching in subsignature checking --- src/elaborate.sml | 63 ++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 41 insertions(+), 22 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index 749bd2f1..f5edbe3e 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2015,6 +2015,41 @@ fun chaseUnifs c = L'.CUnif (_, _, _, _, ref (L'.Known c)) => chaseUnifs c | _ => c +val consEqSimple = + let + fun ces env (c1 : L'.con, c2 : L'.con) = + let + val c1 = hnormCon env c1 + val c2 = hnormCon env c2 + in + case (#1 c1, #1 c2) of + (L'.CRel n1, L'.CRel n2) => n1 = n2 + | (L'.CNamed n1, L'.CNamed n2) => + n1 = n2 orelse + (case #3 (E.lookupCNamed env n1) of + SOME (L'.CNamed n2', _) => n2' = n1 + | _ => false) + | (L'.CModProj n1, L'.CModProj n2) => n1 = n2 + | (L'.CApp (f1, x1), L'.CApp (f2, x2)) => ces env (f1, f2) andalso ces env (x1, x2) + | (L'.CAbs (x1, k1, c1), L'.CAbs (_, _, c2)) => ces (E.pushCRel env x1 k1) (c1, c2) + | (L'.CName x1, L'.CName x2) => x1 = x2 + | (L'.CRecord (_, xts1), L'.CRecord (_, xts2)) => + ListPair.all (fn ((x1, t1), (x2, t2)) => + ces env (x1, x2) andalso ces env (t2, t2)) (xts1, xts2) + | (L'.CConcat (x1, y1), L'.CConcat (x2, y2)) => + ces env (x1, x2) andalso ces env (y1, y2) + | (L'.CMap _, L'.CMap _) => true + | (L'.CUnit, L'.CUnit) => true + | (L'.CTuple cs1, L'.CTuple cs2) => ListPair.all (ces env) (cs1, cs2) + | (L'.CProj (c1, n1), L'.CProj (c2, n2)) => ces env (c1, c2) andalso n1 = n2 + | (L'.CUnif (_, _, _, _, r1), L'.CUnif (_, _, _, _, r2)) => r1 = r2 + | _ => false + end + in + ces + end + + fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)]*) @@ -3020,26 +3055,7 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = | (L'.SgnConst sgis1, L'.SgnConst sgis2) => let - (* This reshuffling was added to avoid some unfortunate unification behavior. - * In particular, in sub-signature checking, constraints might be unified, - * even when we don't expect them to be unifiable, deciding on bad values - * for unification variables and dooming later unification. - * By putting all the constraints _last_, we allow all the other unifications - * to happen first, hoping that no unification variables survive to confuse - * constraint unification. *) - - val sgis2 = - let - val (constraints, others) = List.partition - (fn (L'.SgiConstraint _, _) => true - | _ => false) sgis2 - in - case constraints of - [] => sgis2 - | _ => others @ constraints - end - - (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), + (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), ("sgn2", p_sgn env sgn2), ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)), ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*) @@ -3370,8 +3386,11 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = seek (fn (env, sgi1All as (sgi1, loc)) => case sgi1 of L'.SgiConstraint (c1, d1) => - if consEq env loc (c1, c2) - andalso consEq env loc (d1, d2) then + (* It's important to do only simple equality checking here, + * with no unification, because constraints are unnamed. + * It's too easy to pick the wrong pair to unify! *) + if consEqSimple env (c1, c2) + andalso consEqSimple env (d1, d2) then SOME env else NONE -- cgit v1.2.3 From 26452ecc4b83760962e180a9949e5020cb360cc2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 12:24:38 -0500 Subject: New antiquote syntax for ORDER BY --- doc/manual.tex | 2 +- src/urweb.grm | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 5935ccbf..eb80e0d5 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -2263,7 +2263,7 @@ $$\begin{array}{rrcll} \textrm{Pre-queries} & q &::=& \mt{SELECT} \; [\mt{DISTINCT}] \; P \; \mt{FROM} \; F,^+ \; [\mt{WHERE} \; E] \; [\mt{GROUP} \; \mt{BY} \; p,^+] \; [\mt{HAVING} \; E] \\ &&& \mid q \; R \; q \mid \{\{\{e\}\}\} \\ \textrm{Relational operators} & R &::=& \mt{UNION} \mid \mt{INTERSECT} \mid \mt{EXCEPT} \\ - \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O + \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O \mid \{\{\{e\}\}\} \end{array}$$ $$\begin{array}{rrcll} diff --git a/src/urweb.grm b/src/urweb.grm index 995d1329..56e6d2ac 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -2235,6 +2235,7 @@ obopt : (ECApp ((EVar (["Basis"], "sql_order_by_ (CWild (KRecord (KType, dummy), dummy), dummy)), dummy) | ORDER BY obexps (obexps) + | ORDER BY LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp) obitem : sqlexp diropt (sqlexp, diropt) -- cgit v1.2.3 From 1c58ce1a627bedb4d57e64f429d09721c55de340 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 13:42:20 -0500 Subject: Improve wildify heuristic for finding record type-class witnesses --- src/elaborate.sml | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index f5edbe3e..84d3dc09 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3699,19 +3699,23 @@ and wildifyStr env (str, sgn) = fun should t = let val t = normClassConstraint env' t + + fun shouldR c = + case hnormCon env' c of + (L'.CApp (f, _), _) => + (case hnormCon env' f of + (L'.CApp (f, cl), loc) => + (case hnormCon env' f of + (L'.CMap _, _) => isClassOrFolder env' cl + | _ => false) + | _ => false) + | (L'.CConcat (c1, c2), _) => + shouldR c1 orelse shouldR c2 + | c => false in case #1 t of L'.CApp (f, _) => isClassOrFolder env' f - | L'.TRecord t => - (case hnormCon env' t of - (L'.CApp (f, _), _) => - (case hnormCon env' f of - (L'.CApp (f, cl), loc) => - (case hnormCon env' f of - (L'.CMap _, _) => isClassOrFolder env' cl - | _ => false) - | _ => false) - | _ => false) + | L'.TRecord t => shouldR t | _ => false end in -- cgit v1.2.3 From d30a5ee04dd437f969fca7ad2b3faee7ed324562 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 14:41:23 -0500 Subject: List.mem --- lib/ur/list.ur | 10 ++++++++++ lib/ur/list.urs | 2 ++ 2 files changed, 12 insertions(+) diff --git a/lib/ur/list.ur b/lib/ur/list.ur index cbb4faf2..11895884 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -216,6 +216,16 @@ fun foldlMap [a] [b] [c] f = fold [] end +fun mem [a] (_ : eq a) (x : a) = + let + fun mm ls = + case ls of + [] => False + | y :: ls => y = x || mm ls + in + mm + end + fun find [a] f = let fun find' ls = diff --git a/lib/ur/list.urs b/lib/ur/list.urs index 66007a39..55068935 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -54,6 +54,8 @@ val filterM : m ::: (Type -> Type) -> monad m -> a ::: Type val foldlMap : a ::: Type -> b ::: Type -> c ::: Type -> (a -> b -> c * b) -> b -> t a -> t c * b +val mem : a ::: Type -> eq a -> a -> t a -> bool + val find : a ::: Type -> (a -> bool) -> t a -> option a val search : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> option b -- cgit v1.2.3 From 80e5288d76eaf9fa4ac264e34fd1299d8e4c0642 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 24 Dec 2014 12:35:20 -0500 Subject: Broaden handling of wildcard rewrites --- src/compiler.sml | 12 +++--------- src/settings.sml | 16 ++++++++++++++++ 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index b46643ff..49b251ba 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -693,8 +693,8 @@ fun parseUrp' accLibs fname = | _ => (ErrorMsg.error "Bad path kind spec"; Settings.Any) - fun parseFrom s = - if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then + fun parsePattern s = + if size s > 0 andalso String.sub (s, size s - 1) = #"*" then (Settings.Prefix, String.substring (s, 0, size s - 1)) else (Settings.Exact, s) @@ -709,12 +709,6 @@ fun parseUrp' accLibs fname = | _ => (ErrorMsg.error "Bad filter kind"; url) - fun parsePattern s = - if size s > 0 andalso String.sub (s, size s - 1) = #"*" then - (Settings.Prefix, String.substring (s, 0, size s - 1)) - else - (Settings.Exact, s) - fun read () = case inputCommentableLine inf of EndOfFile => finish [] @@ -801,7 +795,7 @@ fun parseUrp' accLibs fname = fun doit (pkind, from, to, hyph) = let val pkind = parsePkind pkind - val (kind, from) = parseFrom from + val (kind, from) = parsePattern from in rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites end diff --git a/src/settings.sml b/src/settings.sml index eb350c95..fafb38c5 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -378,6 +378,22 @@ type rule = { action : action, kind : pattern_kind, pattern : string } datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool } +fun pak2s pak = + case pak of + Exact => "Exact" + | Prefix => "Prefix" +fun pk2s pk = + case pk of + Any => "Any" + | Url => "Url" + | Table => "Table" + | Sequence => "Sequence" + | View => "View" + | Relation => "Relation" + | Cookie => "Cookie" + | Style => "Style" +fun r2s (r : rewrite) = pak2s (#kind r) ^ " " ^ pk2s (#pkind r) ^ ", from<" ^ #from r ^ ">, to<" ^ #to r ^ ">" + val rewrites = ref ([] : rewrite list) fun subsume (pk1, pk2) = -- cgit v1.2.3 From 0562a6b4d4c94d571abfcd407c98ed259a99bd7e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 25 Dec 2014 18:32:27 -0500 Subject: Client-side conversion of string to bool --- lib/js/urweb.js | 2 ++ src/settings.sml | 2 ++ 2 files changed, 4 insertions(+) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 342dc943..df9097b1 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1261,6 +1261,8 @@ function eh(x) { function ts(x) { return x.toString() } function bs(b) { return (b ? "True" : "False") } +function s2b(s) { return s == "True" ? true : s == "False" ? false : null; } +function s2be(s) { return s == "True" ? true : s == "False" ? false : er("Illegal Boolean " ^ s); } function id(x) { return x; } function sub(s, i) { return s.charAt(i); } diff --git a/src/settings.sml b/src/settings.sml index fafb38c5..343ea358 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -297,6 +297,8 @@ val jsFuncsBase = basisM [("alert", "alert"), ("mouseEvent", "uw_mouseEvent"), ("keyEvent", "uw_keyEvent"), ("minTime", "0"), + ("stringToBool_error", "s2be"), + ("stringToBool", "s2b"), ("islower", "isLower"), ("isupper", "isUpper"), -- cgit v1.2.3 From c72be04ba3d27e8109a2edbea50a391aaa000dfd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 26 Dec 2014 12:30:22 -0500 Subject: Add to .hgignore --- .hgignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.hgignore b/.hgignore index 4139717b..c3272f05 100644 --- a/.hgignore +++ b/.hgignore @@ -62,6 +62,7 @@ m4/lt*.m4 config.* configure depcomp +compile install-sh ltmain.sh missing -- cgit v1.2.3 From 24b9ea0474324a135132390d8bf18d36efea2d4e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2014 17:02:31 -0500 Subject: Fix a bug in subsignature checking for submodules --- src/elaborate.sml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/elaborate.sml b/src/elaborate.sml index 84d3dc09..ca3bac24 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3345,7 +3345,12 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = L'.SgiStr (x', n1, sgn1) => if x = x' then let + (* Don't forget to save & restore the + * counterparts map around recursive calls! + * Otherwise, all sorts of mayhem may result. *) + val saved = !counterparts val () = subSgn' counterparts env loc sgn1 sgn2 + val () = counterparts := saved val env = E.pushStrNamedAs env x n1 sgn1 val env = if n1 = n2 then env -- cgit v1.2.3 From cc8e10b8c398dd73466e9d358e16e14adff2d17f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 3 Jan 2015 09:56:57 -0500 Subject: New release --- CHANGELOG | 8 ++++++++ configure.ac | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 4ac2df97..e0e91e3d 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +======== +20150103 +======== + +- New antiquote syntax for 'ORDER BY' clauses +- New standard library function: List.mem +- Bug fixes and improvements to type inference + ======== 20141206 ======== diff --git a/configure.ac b/configure.ac index 57a4dc02..fb112a22 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20141206]) -WORKING_VERSION=1 +AC_INIT([urweb], [20150103]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 59d197f311ae4d29b9c2c7909ccd8c9c8975c90e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 3 Jan 2015 10:21:26 -0500 Subject: Fixing one small issue with changes to signature matching (grandfathered into release) --- src/elaborate.sml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/elaborate.sml b/src/elaborate.sml index ca3bac24..f6819830 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2043,6 +2043,10 @@ val consEqSimple = | (L'.CTuple cs1, L'.CTuple cs2) => ListPair.all (ces env) (cs1, cs2) | (L'.CProj (c1, n1), L'.CProj (c2, n2)) => ces env (c1, c2) andalso n1 = n2 | (L'.CUnif (_, _, _, _, r1), L'.CUnif (_, _, _, _, r2)) => r1 = r2 + + | (L'.TFun (d1, r1), L'.TFun (d2, r2)) => ces env (d1, d2) andalso ces env (r1, r2) + | (L'.TRecord c1, L'.TRecord c2) => ces env (c1, c2) + | _ => false end in -- cgit v1.2.3 From f1204c9d8702aa2b394d777c0552f5e9cc0e9fce Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 3 Jan 2015 10:28:36 -0500 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index fb112a22..28d1bd8e 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20150103]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 2127b8bbe36c8864919c03a8f09aee5db6595c72 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 7 Jan 2015 09:25:13 -0500 Subject: Fix arguments to PQprepare() --- src/mysql.sml | 2 +- src/postgres.sml | 6 ++---- src/sqlite.sml | 2 +- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/mysql.sml b/src/mysql.sml index 29a8c68f..bb654fee 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -446,7 +446,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => let fun uhoh this s args = box [p_list_sepi (box []) diff --git a/src/postgres.sml b/src/postgres.sml index b97226c1..6df0331a 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -340,14 +340,12 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => box [string "res = PQprepare(conn, \"uw", string (Int.toString i), string "\", \"", string (Prim.toCString s), - string "\", ", - string (Int.toString n), - string ", NULL);", + string "\", 0, NULL);", newline, string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", newline, diff --git a/src/sqlite.sml b/src/sqlite.sml index c138415b..a1095709 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -202,7 +202,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => let fun uhoh this s args = box [p_list_sepi (box []) -- cgit v1.2.3 From 9b8fc824ae3fe7176abf67fecb811dd5bdb89cda Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 12 Jan 2015 12:02:54 -0500 Subject: Switch to using OpenSSL PRNG for the one remaining rand() --- src/c/urweb.c | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index e2881b05..4a00755b 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -167,6 +167,19 @@ void *uw_init_client_data(); void uw_free_client_data(void *); void uw_copy_client_data(void *dst, void *src); +static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; + +static uw_Basis_int my_rand() { + pthread_mutex_lock(&rand_mutex); + int r = RAND_bytes((unsigned char *)&ret, sizeof ret); + pthread_mutex_unlock(&rand_mutex); + + if (r) + return abs(r); + else + return -1; +} + static client *new_client() { client *c; @@ -192,7 +205,7 @@ static client *new_client() { pthread_mutex_lock(&c->lock); c->mode = USED; - c->pass = rand(); + c->pass = my_rand(); c->sock = -1; c->last_contact = time(NULL); uw_buffer_reset(&c->msgs); @@ -4221,16 +4234,11 @@ uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) { return uw_unit_v; } -static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; - uw_Basis_int uw_Basis_rand(uw_context ctx) { - uw_Basis_int ret; - pthread_mutex_lock(&rand_mutex); - int r = RAND_bytes((unsigned char *)&ret, sizeof ret); - pthread_mutex_unlock(&rand_mutex); + int r = my_rand(); - if (r) - return abs(ret); + if (r >= 0) + return r; else uw_error(ctx, FATAL, "Random number generation failed"); } -- cgit v1.2.3 From 2207f580efc424d40c81d4dd98fb414e29eaa7f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 09:46:20 -0500 Subject: Fix silly mistake from last commit; also switch away from rand() in openssl.c --- src/c/openssl.c | 10 ++++++---- src/c/urweb.c | 6 ++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/c/openssl.c b/src/c/openssl.c index 6a998e29..1d820a34 100644 --- a/src/c/openssl.c +++ b/src/c/openssl.c @@ -9,6 +9,7 @@ #include #include +#include #define PASSSIZE 4 @@ -19,10 +20,11 @@ static int password[PASSSIZE]; char *uw_sig_file = NULL; static void random_password() { - int i; - - for (i = 0; i < PASSSIZE; ++i) - password[i] = rand(); + if (!RAND_bytes((unsigned char *)password, sizeof password)) { + fprintf(stderr, "Error generating random password\n"); + perror("RAND_bytes"); + exit(1); + } } void uw_init_crypto() { diff --git a/src/c/urweb.c b/src/c/urweb.c index 4a00755b..7ad58e1d 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -171,11 +171,11 @@ static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; static uw_Basis_int my_rand() { pthread_mutex_lock(&rand_mutex); - int r = RAND_bytes((unsigned char *)&ret, sizeof ret); + int ret, r = RAND_bytes((unsigned char *)&ret, sizeof ret); pthread_mutex_unlock(&rand_mutex); if (r) - return abs(r); + return abs(ret); else return -1; } @@ -362,8 +362,6 @@ extern void uw_global_custom(); extern void uw_init_crypto(); void uw_global_init() { - srand(time(NULL) ^ getpid()); - clients = malloc(0); uw_global_custom(); -- cgit v1.2.3 From d64871d978719a36f3f52d6fdaef80fc757fa752 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 09:55:05 -0500 Subject: Fix a potential memory bug in fastcgi.c --- src/c/fastcgi.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c index f3e66e3a..cda3e1f6 100644 --- a/src/c/fastcgi.c +++ b/src/c/fastcgi.c @@ -333,7 +333,7 @@ static void *worker(void *data) { size_t path_size = 0; char *path_buf = malloc(0); - hs.uppercased = malloc(0); + hs.uppercased = malloc(6); hs.uppercased_len = 0; hs.nvps = malloc(sizeof(nvp)); hs.n_nvps = 1; -- cgit v1.2.3 From df953c3e45f9360ee3523ebf0541bdf962fbe7b9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 11:00:17 -0500 Subject: Reference manual: fix rendering of field removal operators --- doc/manual.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index eb80e0d5..bcdb7f35 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -6,8 +6,8 @@ \newcommand{\mt}[1]{\mathsf{#1}} \newcommand{\rc}{+ \hspace{-.075in} + \;} -\newcommand{\rcut}{\; \texttt{--} \;} -\newcommand{\rcutM}{\; \texttt{---} \;} +\newcommand{\rcut}{\; \texttt{-{}-} \;} +\newcommand{\rcutM}{\; \texttt{-{}-{}-} \;} \begin{document} -- cgit v1.2.3 From d3e13c67397dd99d4aa30681c05a02cd31d9e386 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 11:26:24 -0500 Subject: Fix case issue in name mangling for MySQL --- src/settings.sml | 45 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 38 insertions(+), 7 deletions(-) diff --git a/src/settings.sml b/src/settings.sml index 343ea358..19ee0b4a 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -744,15 +744,46 @@ fun capitalize s = "" => "" | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) +val allLower = CharVector.map Char.toLower + val mangle = ref true fun setMangleSql x = mangle := x -fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s - else if #name (currentDbms ()) = "mysql" then capitalize s - else lowercase s -fun mangleSql s = if !mangle then "uw_" ^ s - else if #name (currentDbms ()) = "mysql" then lowercase s - else lowercase s -fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s + +fun mangleSqlTable s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ capitalize s + else + lowercase s + +fun mangleSql s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s + +fun mangleSqlCatalog s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s val html5 = ref false fun setIsHtml5 b = html5 := b -- cgit v1.2.3 From 2200a9e67a5e280406f55048dc03b5a8fd51d642 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 28 Jan 2015 08:47:04 -0500 Subject: Improve wildification for records of type-class witnesses --- src/elaborate.sml | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index f6819830..5b18ae94 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3697,6 +3697,21 @@ and wildifyStr env (str, sgn) = | c => ((*Print.preface ("WTF?", p_con env (c, loc));*) NONE) + fun isClassOrFolder' env (c : L'.con) = + case #1 c of + L'.CAbs (x, k, c) => + let + val env = E.pushCRel env x k + + fun toHead (c : L'.con) = + case #1 c of + L'.CApp (c, _) => toHead c + | _ => isClassOrFolder env c + in + toHead (hnormCon env c) + end + | _ => isClassOrFolder env c + fun buildNeeded env sgis = #1 (foldl (fn ((sgi, loc), (nd, env')) => (case sgi of @@ -3715,7 +3730,7 @@ and wildifyStr env (str, sgn) = (case hnormCon env' f of (L'.CApp (f, cl), loc) => (case hnormCon env' f of - (L'.CMap _, _) => isClassOrFolder env' cl + (L'.CMap _, _) => isClassOrFolder' env' cl | _ => false) | _ => false) | (L'.CConcat (c1, c2), _) => -- cgit v1.2.3 From eab0e09b2b4d125abb98e088ff9a03581aa05717 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Feb 2015 12:29:14 -0500 Subject: A new MonoReduce optimization for lifting 'let' out of field projection; JavaScript compilation for exponentiation --- lib/js/urweb.js | 4 ++++ src/jscomp.sml | 2 ++ src/mono_reduce.sml | 17 +++++++++++++---- 3 files changed, 19 insertions(+), 4 deletions(-) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index df9097b1..3bf21dd2 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -112,6 +112,10 @@ function round(n) { return Math.round(n); } +function pow(n, m) { + return Math.pow(n, m); +} + // Time, represented as counts of microseconds since the epoch diff --git a/src/jscomp.sml b/src/jscomp.sml index 1a476739..3709bcd3 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -724,6 +724,8 @@ fun process (file : file) = | "<" => "lt" | "<=" => "le" | "strcmp" => "strcmp" + | "powl" => "pow" + | "powf" => "pow" | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s) val (e1, st) = jsE inner (e1, st) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 8ca84c15..39d02b99 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -818,10 +818,19 @@ fun reduce (file : file) = search pes end - | EField ((ERecord xes, _), x) => - (case List.find (fn (x', _, _) => x' = x) xes of - SOME (_, e, _) => #1 e - | NONE => e) + | EField (e1, x) => + let + fun yankLets (e : exp) = + case #1 e of + ELet (x, t, e1, e2) => (ELet (x, t, e1, yankLets e2), #2 e) + | ERecord xes => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => e + | NONE => (EField (e, x), #2 e)) + | _ => (EField (e, x), #2 e) + in + #1 (yankLets e1) + end | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => let -- cgit v1.2.3 From 9d277854b9a4fb3ac30bea989c10d7f550e960b4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Feb 2015 15:50:54 -0500 Subject: Don't allow singleton