Relational operators portability

6 files changed, 50 insertions, 18 deletions

diff --git a/src/monoize.sml b/src/monoize.sml
index 9799ae95..25ea87f5 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2403,16 +2403,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 val s = (L'.TFfi ("Basis", "string"), loc)
                 fun sc s = (L'.EPrim (Prim.String s), loc)
             in
-                ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
-                           (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
-                                     (L'.EAbs ("e2", s, s,
-                                               strcat [sc "((",
-                                                       (L'.ERel 1, loc),
-                                                       sc ") ",
-                                                       (L'.ERel 2, loc),
-                                                       sc " (",
-                                                       (L'.ERel 0, loc),
-                                                       sc "))"]), loc)), loc)), loc),
+                (if #nestedRelops (Settings.currentDbms ()) then
+                     (L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                               (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
+                                         (L'.EAbs ("e2", s, s,
+                                                   strcat [sc "((",
+                                                           (L'.ERel 1, loc),
+                                                           sc ") ",
+                                                           (L'.ERel 2, loc),
+                                                           sc " (",
+                                                           (L'.ERel 0, loc),
+                                                           sc "))"]), loc)), loc)), loc)
+                 else
+                   (L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                               (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
+                                         (L'.EAbs ("e2", s, s,
+                                                   strcat [(L'.ERel 1, loc),
+                                                           sc " ",
+                                                           (L'.ERel 2, loc),
+                                                           sc " ",
+                                                           (L'.ERel 0, loc)]), loc)), loc)), loc),
                  fm)
             end
           | L.ECApp (
@@ -2433,8 +2443,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             end
 
           | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
-          | L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
-          | L.EFfi ("Basis", "sql_except") => ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)
+          | L.EFfi ("Basis", "sql_intersect") =>
+            (if #onlyUnion (Settings.currentDbms ()) then
+                 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT."
+             else
+                 ();
+             ((L'.EPrim (Prim.String "INTERSECT"), loc), fm))
+          | L.EFfi ("Basis", "sql_except") =>
+            (if #onlyUnion (Settings.currentDbms ()) then
+                 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT."
+             else
+                 ();
+             ((L'.EPrim (Prim.String "EXCEPT"), loc), fm))
 
           | L.ECApp (
             (L.ECApp (
diff --git a/src/mysql.sml b/src/mysql.sml
index b894bfac..fa49ced3 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1544,6 +1544,8 @@ val () = addDbms {name = "mysql",
                   sqlPrefix = "SET storage_engine=InnoDB;\n\n",
                   supportsOctetLength = true,
                   trueString = "TRUE",
-                  falseString = "FALSE"}
+                  falseString = "FALSE",
+                  onlyUnion = true,
+                  nestedRelops = false}
 
 end
diff --git a/src/postgres.sml b/src/postgres.sml
index a3f33db1..8541ca4a 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -951,7 +951,9 @@ val () = addDbms {name = "postgres",
                   sqlPrefix = "",
                   supportsOctetLength = true,
                   trueString = "TRUE",
-                  falseString = "FALSE"}
+                  falseString = "FALSE",
+                  onlyUnion = false,
+                  nestedRelops = true}
 
 val () = setDbms "postgres"
 
diff --git a/src/settings.sig b/src/settings.sig
index 94472eb1..a5f0cfa7 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -167,7 +167,9 @@ signature SETTINGS = sig
          sqlPrefix : string,
          supportsOctetLength : bool,
          trueString : string,
-         falseString : string
+         falseString : string,
+         onlyUnion : bool,
+         nestedRelops : bool
     }
 
     val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index 97c16675..b9056c5b 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -383,7 +383,9 @@ type dbms = {
      sqlPrefix : string,
      supportsOctetLength : bool,
      trueString : string,
-     falseString : string
+     falseString : string,
+     onlyUnion : bool,
+     nestedRelops : bool
 }
 
 val dbmses = ref ([] : dbms list)
@@ -411,7 +413,9 @@ val curDb = ref ({name = "",
                   sqlPrefix = "",
                   supportsOctetLength = false,
                   trueString = "",
-                  falseString = ""} : dbms)
+                  falseString = "",
+                  onlyUnion = false,
+                  nestedRelops = false} : dbms)
 
 fun addDbms v = dbmses := v :: !dbmses
 fun setDbms s =
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 593db22e..26cfc9d5 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -837,6 +837,8 @@ val () = addDbms {name = "sqlite",
                   sqlPrefix = "",
                   supportsOctetLength = false,
                   trueString = "1",
-                  falseString = "0"}
+                  falseString = "0",
+                  onlyUnion = false,
+                  nestedRelops = false}
 
 end