diff options
Diffstat (limited to 'src')
40 files changed, 239 insertions, 225 deletions
diff --git a/src/c/openssl.c b/src/c/openssl.c index 981d48da..15c4de5e 100644 --- a/src/c/openssl.c +++ b/src/c/openssl.c @@ -35,14 +35,15 @@ static void random_password() { // OpenSSL callbacks #ifdef PTHREAD_T_IS_POINTER -# define CRYPTO_THREADID_SET CRYPTO_THREADID_set_pointer +static void thread_id(CRYPTO_THREADID *const result) { + CRYPTO_THREADID_set_pointer(result, pthread_self()); +} #else -# define CRYPTO_THREADID_SET CRYPTO_THREADID_set_numeric -#endif static void thread_id(CRYPTO_THREADID *const result) { - CRYPTO_THREADID_SET(result, pthread_self()); + CRYPTO_THREADID_set_numeric(result, (unsigned long)pthread_self()); } -#undef CRYPTO_THREADID_SET +#endif + static void lock_or_unlock(const int mode, const int type, const char *file, const int line) { pthread_mutex_t *const lock = &openssl_locks[type]; diff --git a/src/c/urweb.c b/src/c/urweb.c index 50aac5e8..c057688c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4562,13 +4562,6 @@ void uw_set_remoteSock(uw_context ctx, int sock) { // Sqlcache -typedef struct uw_Sqlcache_Entry { - char *key; - uw_Sqlcache_Value *value; - unsigned long timeInvalid; - UT_hash_handle hh; -} uw_Sqlcache_Entry; - static void uw_Sqlcache_freeValue(uw_Sqlcache_Value *value) { if (value) { free(value->result); diff --git a/src/cjr.sml b/src/cjr.sml index 3742a06f..e582e6ae 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -46,8 +46,7 @@ datatype patCon = | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} datatype pat' = - PWild - | PVar of string * typ + PVar of string * typ | PPrim of Prim.t | PCon of datatype_kind * patCon * pat option | PRecord of (string * pat * typ) list diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 2c2133d6..2471ce59 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -163,9 +163,7 @@ fun p_con_named env n = fun p_pat_preamble env (p, _) = case p of - PWild => (box [], - env) - | PVar (x, t) => (box [p_typ env t, + PVar (x, t) => (box [p_typ env t, space, string "__uwr_", p_ident x, @@ -194,8 +192,7 @@ fun p_patCon env pc = fun p_patMatch (env, disc) (p, loc) = case p of - PWild => string "1" - | PVar _ => string "1" + PVar _ => string "1" | PPrim (Prim.Int n) => box [string ("(" ^ disc), space, string "==", @@ -318,9 +315,7 @@ fun p_patMatch (env, disc) (p, loc) = fun p_patBind (env, disc) (p, loc) = case p of - PWild => - (box [], env) - | PVar (x, t) => + PVar (x, t) => (box [p_typ env t, space, string "__uwr_", @@ -2356,7 +2351,7 @@ fun p_fun isRec env (fx, n, args, ran, e) = val global_initializers : Print.PD.pp_desc list ref = ref [] -fun p_decl env (dAll as (d, _) : decl) = +fun p_decl env (dAll as (d, loc) : decl) = case d of DStruct (n, xts) => let @@ -2378,9 +2373,6 @@ fun p_decl env (dAll as (d, _) : decl) = end | DDatatype dts => let - val dts = ListMergeSort.sort (fn ((dk1, _, _, _), (dk2, _, _, _)) => - dk1 = Enum andalso dk2 <> Enum) dts - fun p_one (Enum, x, n, xncs) = box [string "enum", space, @@ -2605,6 +2597,23 @@ fun p_file env (ds, ps) = self := NONE; global_initializers := []) + (* First, pull out all of the enumerated types, to be declared first. *) + val (ds, enums) = ListUtil.foldlMapPartial (fn (d, enums) => + case #1 d of + DDatatype dts => + let + val (enum, other) = List.partition (fn (Enum, _, _, _) => true + | _ => false) dts + in + (SOME (DDatatype other, #2 d), + List.revAppend (enum, enums)) + end + | DDatatypeForward (Enum, _, _) => (NONE, enums) + | _ => (SOME d, enums)) + [] ds + + val ds = (DDatatype enums, ErrorMsg.dummySpan) :: ds + val (pds, env) = ListUtil.foldlMap (fn (d, env) => let val d' = p_decl env d diff --git a/src/cjrize.sml b/src/cjrize.sml index 5f6ae4d8..fbc7eba1 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -191,8 +191,7 @@ fun cifyPatCon (pc, sm) = fun cifyPat ((p, loc), sm) = case p of - L.PWild => ((L'.PWild, loc), sm) - | L.PVar (x, t) => + L.PVar (x, t) => let val (t, sm) = cifyTyp (t, sm) in diff --git a/src/compiler.sml b/src/compiler.sml index bf7491e5..7580c5e4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, 2014, Adam Chlipala +(* Copyright (c) 2008-2012, 2014, 2016, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -412,6 +412,14 @@ fun inputCommentableLine inf = val lastUrp = ref "" +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) + fun parseUrp' accLibs fname = (lastUrp := fname; if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", [])) @@ -459,6 +467,7 @@ fun parseUrp' accLibs fname = let val pathmap = ref (!pathmap) val bigLibs = ref [] + val libSet = ref SS.empty fun pu filename = let @@ -822,10 +831,19 @@ fun parseUrp' accLibs fname = fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind end | _ => ErrorMsg.error "Bad 'deny' syntax") - | "library" => if accLibs then - libs := pu (libify (relify arg)) :: !libs - else - bigLibs := libify' arg :: !bigLibs + | "library" => + if accLibs then + let + val arg = libify (relify arg) + in + if SS.member (!libSet, arg) then + () + else + (libs := pu arg :: !libs; + libSet := SS.add (!libSet, arg)) + end + else + bigLibs := libify' arg :: !bigLibs | "path" => (case String.fields (fn ch => ch = #"=") arg of [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir})) @@ -878,7 +896,7 @@ fun parseUrp' accLibs fname = | "jsFile" => (Settings.setFilePath thisPath; Settings.addJsFile arg) - + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end @@ -936,14 +954,6 @@ fun addModuleRoot (k, v) = moduleRoots := relativeTo = OS.FileSys.getDir ()}, v) :: !moduleRoots -structure SK = struct -type ord_key = string -val compare = String.compare -end - -structure SS = BinarySetFn(SK) -structure SM = BinaryMapFn(SK) - exception MissingFile of string val parse = { @@ -1503,7 +1513,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = let val proto = Settings.currentProtocol () - val lib = if Settings.getStaticLinking () then + val lib = if Settings.getBootLinking () then + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + else if Settings.getStaticLinking () then " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" @@ -1518,7 +1530,16 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = ^ " " ^ #compile proto ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname - val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " " ^ Config.pthreadLibs) + fun concatArgs (a1, a2) = + if CharVector.all Char.isSpace a1 then + a2 + else + a1 ^ " " ^ a2 + + val args = concatArgs (Config.ccArgs, Config.pthreadCflags) + val args = concatArgs (args, Config.pthreadLibs) + + val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ args) val ssl = if Settings.getStaticLinking () then Config.openssl ^ " -ldl -lz" diff --git a/src/core.sml b/src/core.sml index 193825bf..8f57c31f 100644 --- a/src/core.sml +++ b/src/core.sml @@ -78,8 +78,7 @@ datatype patCon = con : string, arg : con option, kind : datatype_kind} datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/core_env.sml b/src/core_env.sml index 9a4f9ec7..7d78bdee 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -354,8 +354,7 @@ fun declBinds env (d, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p @@ -363,8 +362,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, loc) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBindsN p @@ -372,8 +370,7 @@ fun patBindsN (p, loc) = fun patBindsL (p, loc) = case p of - PWild => [] - | PVar (x, t) => [(x, t)] + PVar (x, t) => [(x, t)] | PPrim _ => [] | PCon (_, _, _, NONE) => [] | PCon (_, _, _, SOME p) => patBindsL p diff --git a/src/core_print.sml b/src/core_print.sml index f360f346..5c71e978 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -224,8 +224,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, n, _, NONE) => p_patCon env n | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n, diff --git a/src/core_util.sml b/src/core_util.sml index 9ca85c37..57ef16f7 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -416,11 +416,7 @@ fun pcCompare (pc1, pc2) = fun pCompare ((p1, _), (p2, _)) = case (p1, p2) of - (PWild, PWild) => EQUAL - | (PWild, _) => LESS - | (_, PWild) => GREATER - - | (PVar _, PVar _) => EQUAL + (PVar _, PVar _) => EQUAL | (PVar _, _) => LESS | (_, PVar _) => GREATER @@ -712,8 +708,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => pb (p, ctx) @@ -771,8 +766,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfp ctx (pAll as (p, loc)) = case p of - PWild => S.return2 pAll - | PVar (x, t) => + PVar (x, t) => S.map2 (mfc ctx t, fn t' => (PVar (x, t'), loc)) diff --git a/src/corify.sml b/src/corify.sml index 5d58efcc..19cd3ec8 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -529,8 +529,7 @@ fun corifyPatCon st pc = fun corifyPat st (p, loc) = case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc) + L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, ts, po) => (L'.PCon (dk, corifyPatCon st pc, map (corifyCon st) ts, Option.map (corifyPat st) po), loc) diff --git a/src/elab.sml b/src/elab.sml index 209d3307..90c14e4b 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -97,8 +97,7 @@ datatype patCon = | PConProj of int * string list * string datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/elab_env.sml b/src/elab_env.sml index 3523b576..cb08f348 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1563,8 +1563,7 @@ fun projectConstraints env {sgn, str} = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p @@ -1572,8 +1571,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBindsN p diff --git a/src/elab_print.sml b/src/elab_print.sml index 5a41883f..06ea097f 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -289,8 +289,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, pc, _, NONE) => p_patCon env pc | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc, diff --git a/src/elab_util.sml b/src/elab_util.sml index ed2e82a0..0cdb9cc1 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -346,8 +346,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fun doVars ((p, _), ctx) = case p of - PWild => ctx - | PVar xt => bind (ctx, RelE xt) + PVar xt => bind (ctx, RelE xt) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => doVars (p, ctx) @@ -452,8 +451,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, _, NONE) => ctx | PCon (_, _, _, SOME p) => pb (p, ctx) @@ -517,8 +515,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfp ctx (pAll as (p, loc)) = case p of - PWild => S.return2 pAll - | PVar (x, t) => + PVar (x, t) => S.map2 (mfc ctx t, fn t' => (PVar (x, t'), loc)) diff --git a/src/elaborate.sml b/src/elaborate.sml index 25cce6bd..6965adfd 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -163,22 +163,25 @@ r := L'.KKnown k1All) handle Subscript => err KIncompatible) | (L'.KTupleUnif (loc, nks1, r1 as ref (L'.KUnknown f1)), L'.KTupleUnif (_, nks2, r2 as ref (L'.KUnknown f2))) => - let - val nks = foldl (fn (p as (n, k1), nks) => - case ListUtil.search (fn (n', k2) => - if n' = n then - SOME k2 - else - NONE) nks2 of - NONE => p :: nks - | SOME k2 => (unifyKinds' env k1 k2; - nks)) nks2 nks1 + if r1 = r2 then + () + else + let + val nks = foldl (fn (p as (n, k1), nks) => + case ListUtil.search (fn (n', k2) => + if n' = n then + SOME k2 + else + NONE) nks2 of + NONE => p :: nks + | SOME k2 => (unifyKinds' env k1 k2; + nks)) nks2 nks1 - val k = (L'.KTupleUnif (loc, nks, ref (L'.KUnknown (fn x => f1 x andalso f2 x))), loc) - in - r1 := L'.KKnown k; - r2 := L'.KKnown k - end + val k = (L'.KTupleUnif (loc, nks, ref (L'.KUnknown (fn x => f1 x andalso f2 x))), loc) + in + r1 := L'.KKnown k; + r2 := L'.KKnown k + end | _ => err KIncompatible end @@ -282,6 +285,7 @@ fun hnormKind (kAll as (k, _)) = case k of L'.KUnif (_, _, ref (L'.KKnown k)) => hnormKind k + | L'.KTupleUnif (_, _, ref (L'.KKnown k)) => hnormKind k | _ => kAll open ElabOps @@ -641,10 +645,10 @@ | (L'.KUnif (_, _, r), _) => let val ku = kunif env loc - val k = (L'.KTupleUnif (loc, [(n, ku)], r), loc) + val k = (L'.KTupleUnif (loc, [(n, ku)], ref (L'.KUnknown (fn _ => true))), loc) in r := L'.KKnown k; - k + ku end | (L'.KTupleUnif (_, nks, r), _) => (case ListUtil.search (fn (n', k) => if n' = n then SOME k else NONE) nks of @@ -652,10 +656,10 @@ | NONE => let val ku = kunif env loc - val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), r), loc) + val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), ref (L'.KUnknown (fn _ => true))), loc) in r := L'.KKnown k; - k + ku end) | k => raise CUnify' (env, CKindof (k, c, "tuple"))) @@ -1341,6 +1345,31 @@ | (L'.CProj (c1, n1), _) => projSpecial1 (c1, n1, fn () => err CIncompatible) | (_, L'.CProj (c2, n2)) => projSpecial2 (c2, n2, fn () => err CIncompatible) + | (L'.CTuple cs, L'.CRel x) => + (case hnormKind (kindof env c2All) of + (L'.KTuple ks, _) => + if length cs <> length ks then + err CIncompatible + else + let + fun rightProjs (cs, n) = + case cs of + c :: cs' => + (case hnormCon env c of + (L'.CProj ((L'.CRel x', _), n'), _) => + x' = x andalso n' = n andalso rightProjs (cs', n+1) + | _ => false) + | [] => true + in + if rightProjs (cs, 1) then + () + else + err CIncompatible + end + | _ => err CIncompatible) + | (L'.CRel x, L'.CTuple cs) => + unifyCons'' env loc c2All c1All + | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) => (unifyKinds env dom1 dom2; unifyKinds env ran1 ran2) @@ -1497,8 +1526,8 @@ fun elabPat (pAll as (p, loc), (env, bound)) = let - val perror = (L'.PWild, loc) val terror = (L'.CError, loc) + val perror = (L'.PVar ("_", terror), loc) val pterror = (perror, terror) val rerror = (pterror, (env, bound)) @@ -1534,11 +1563,9 @@ fun elabPat (pAll as (p, loc), (env, bound)) = end in case p of - L.PWild => (((L'.PWild, loc), cunif env (loc, (L'.KType, loc))), - (env, bound)) - | L.PVar x => + L.PVar x => let - val t = if SS.member (bound, x) then + val t = if x <> "_" andalso SS.member (bound, x) then (expError env (DuplicatePatternVariable (loc, x)); terror) else @@ -1613,6 +1640,8 @@ fun elabPat (pAll as (p, loc), (env, bound)) = (* This exhaustiveness checking follows Luc Maranget's paper "Warnings for pattern matching." *) fun exhaustive (env, t, ps, loc) = let + val pwild = L'.PVar ("_", t) + fun fail n = raise Fail ("Elaborate.exhaustive: Impossible " ^ Int.toString n) fun patConNum pc = @@ -1654,7 +1683,7 @@ fun exhaustive (env, t, ps, loc) = val loc = #2 p1 fun wild () = - SOME (map (fn _ => (L'.PWild, loc)) args @ ps) + SOME (map (fn _ => (pwild, loc)) args @ ps) in case #1 p1 of L'.PPrim _ => NONE @@ -1675,9 +1704,8 @@ fun exhaustive (env, t, ps, loc) = SOME p else NONE) xpts of - NONE => (L'.PWild, loc) + NONE => (pwild, loc) | SOME p => p) args @ ps) - | L'.PWild => wild () | L'.PVar _ => wild () end) P @@ -1687,8 +1715,7 @@ fun exhaustive (env, t, ps, loc) = (fn [] => fail 2 | (p1, _) :: ps => case p1 of - L'.PWild => SOME ps - | L'.PVar _ => SOME ps + L'.PVar _ => SOME ps | L'.PPrim _ => NONE | L'.PCon _ => NONE | L'.PRecord _ => NONE) @@ -1818,8 +1845,8 @@ fun exhaustive (env, t, ps, loc) = | SOME ps => let val p = case cons of - [] => L'.PWild - | (0, _) :: _ => L'.PWild + [] => pwild + | (0, _) :: _ => pwild | _ => case IS.find (fn _ => true) unused of NONE => fail 6 @@ -1832,7 +1859,7 @@ fun exhaustive (env, t, ps, loc) = SOME (n, []) => L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], NONE) | SOME (n, [_]) => - L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (L'.PWild, loc)) + L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (pwild, loc)) | _ => fail 7 in SOME ((p, loc) :: ps) diff --git a/src/expl.sml b/src/expl.sml index 3d784e3f..994c05cf 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -77,8 +77,7 @@ datatype patCon = | PConProj of int * string list * string datatype pat' = - PWild - | PVar of string * con + PVar of string * con | PPrim of Prim.t | PCon of datatype_kind * patCon * con list * pat option | PRecord of (string * pat * con) list diff --git a/src/expl_env.sml b/src/expl_env.sml index 5712a72d..f7f51be5 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -404,8 +404,7 @@ fun sgiBinds env (sgi, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t + PVar (x, t) => pushERel env x t | PPrim _ => env | PCon (_, _, _, NONE) => env | PCon (_, _, _, SOME p) => patBinds env p diff --git a/src/expl_print.sml b/src/expl_print.sml index 22d246e2..10ea6056 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -215,8 +215,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, pc, _, NONE) => p_patCon env pc | PCon (_, pc, cs, SOME p) => diff --git a/src/expl_rename.sml b/src/expl_rename.sml index bb763a60..bdcf1aa4 100644 --- a/src/expl_rename.sml +++ b/src/expl_rename.sml @@ -99,8 +99,7 @@ fun renamePatCon st pc = fun renamePat st (all as (p, loc)) = case p of - PWild => all - | PVar (x, c) => (PVar (x, renameCon st c), loc) + PVar (x, c) => (PVar (x, renameCon st c), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, renamePatCon st pc, map (renameCon st) cs, diff --git a/src/explify.sml b/src/explify.sml index f38151d2..e2a317a2 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -90,8 +90,7 @@ fun explifyPatCon pc = fun explifyPat (p, loc) = case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc) + L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, cs, po) => (L'.PCon (dk, explifyPatCon pc, map explifyCon cs, Option.map explifyPat po), loc) | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, explifyPat p, explifyCon t)) xps), loc) diff --git a/src/iflow.sml b/src/iflow.sml index 8bde7ea3..5e8d697e 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1405,8 +1405,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun evalPat env e (pt, _) = case pt of - PWild => env - | PVar _ => e :: env + PVar _ => e :: env | PPrim _ => env | PCon (_, pc, NONE) => (St.assert [AReln (PCon0 (patCon pc), [e])]; env) | PCon (_, pc, SOME pt) => @@ -2045,8 +2044,7 @@ fun check (file : file) = let fun doPat (p, env) = case #1 p of - PWild => env - | PVar _ => v :: env + PVar _ => v :: env | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => doPat (p, env) diff --git a/src/jscomp.sml b/src/jscomp.sml index e5a0cb27..65a0fa3a 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -458,8 +458,7 @@ fun process (file : file) = fun jsPat (p, _) = case p of - PWild => str "{c:\"w\"}" - | PVar _ => str "{c:\"v\"}" + PVar _ => str "{/*hoho*/c:\"v\"}" | PPrim p => strcat [str "{c:\"c\",v:", jsPrim p, str "}"] @@ -1009,8 +1008,7 @@ fun process (file : file) = fun patBinds ((p, _), env) = case p of - PWild => env - | PVar (_, t) => t :: env + PVar (_, t) => t :: env | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => patBinds (p, env) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 67732b58..f595134f 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -64,7 +64,7 @@ fun oneRun args = fun doArgs args = case args of [] => () - | "-version" :: rest => + | "-version" :: rest => printVersion () | "-numeric-version" :: rest => printNumericVersion () @@ -151,7 +151,7 @@ fun oneRun args = doArgs rest) | "-boot" :: rest => (Compiler.enableBoot (); - Settings.setStaticLinking true; + Settings.setBootLinking true; doArgs rest) | "-sigfile" :: name :: rest => (Settings.setSigFile (SOME name); @@ -318,7 +318,7 @@ val () = case CommandLine.arguments () of (* Redirect the daemon's output to the socket. *) redirect Posix.FileSys.stdout; redirect Posix.FileSys.stderr; - + loop' ("", []); Socket.close sock; diff --git a/src/mono.sml b/src/mono.sml index b05c3dcc..cdadded5 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -48,8 +48,7 @@ datatype patCon = | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} datatype pat' = - PWild - | PVar of string * typ + PVar of string * typ | PPrim of Prim.t | PCon of datatype_kind * patCon * pat option | PRecord of (string * pat * typ) list diff --git a/src/mono_env.sml b/src/mono_env.sml index 52e07893..0dd668ea 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -148,8 +148,7 @@ fun declBinds env (d, loc) = fun patBinds env (p, loc) = case p of - PWild => env - | PVar (x, t) => pushERel env x t NONE + PVar (x, t) => pushERel env x t NONE | PPrim _ => env | PCon (_, _, NONE) => env | PCon (_, _, SOME p) => patBinds env p @@ -159,8 +158,7 @@ fun patBinds env (p, loc) = fun patBindsN (p, loc) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, NONE) => 0 | PCon (_, _, SOME p) => patBindsN p diff --git a/src/mono_print.sml b/src/mono_print.sml index 3e498d2c..a3b55ec0 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -105,8 +105,7 @@ fun p_patCon env pc = fun p_pat' par env (p, _) = case p of - PWild => string "_" - | PVar (s, _) => string s + PVar (s, _) => string s | PPrim p => Prim.p_t p | PCon (_, n, NONE) => p_patCon env n | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 61866af7..540d396b 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -191,8 +191,7 @@ datatype result = Yes of (string * typ * exp) list | No | Maybe fun match (env, p : pat, e : exp) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes ((x, t, e) :: env) + (PVar (x, t), _) => Yes ((x, t, e) :: env) | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) => if String.isPrefix s' s then @@ -300,8 +299,7 @@ val p_events = Print.p_list p_event fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, NONE) => 0 | PCon (_, _, SOME p) => patBinds p diff --git a/src/mono_util.sml b/src/mono_util.sml index 5d7eb164..fc1a2bcb 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -235,8 +235,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = let fun pb ((p, _), ctx) = case p of - PWild => ctx - | PVar (x, t) => bind (ctx, RelE (x, t)) + PVar (x, t) => bind (ctx, RelE (x, t)) | PPrim _ => ctx | PCon (_, _, NONE) => ctx | PCon (_, _, SOME p) => pb (p, ctx) diff --git a/src/monoize.sml b/src/monoize.sml index 75851a48..6715290f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -440,8 +440,7 @@ fun monoPat env (all as (p, loc)) = dummyPat) in case p of - L.PWild => (L'.PWild, loc) - | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) + L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) | L.PPrim p => (L'.PPrim p, loc) | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc) | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) => @@ -1430,16 +1429,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = string), ("2", str (Settings.mangleSql (lowercaseFirst nm2)), string)], loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", string), loc), (L'.ERecord [("1", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm1) ^ ", "), - (L'.EField ((L'.ERel 0, loc), "1"), loc)), + (L'.EField ((L'.ERel 1, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( str (Settings.mangleSql (lowercaseFirst nm2) ^ ", "), - (L'.EField ((L'.ERel 0, loc), "2"), loc)), + (L'.EField ((L'.ERel 1, loc), "2"), loc)), loc), string)], loc))], {disc = string, @@ -1484,9 +1483,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc), [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc), str ""), - ((L'.PWild, loc), + ((L'.PVar ("_", string), loc), strcat [str (" ON " ^ kw ^ " "), - (L'.EField ((L'.ERel 0, loc), fd), loc)])], + (L'.EField ((L'.ERel 1, loc), fd), loc)])], {disc = string, result = string}), loc) in @@ -2013,6 +2012,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc), (L'.EAbs ("tab2", s, s, @@ -2022,17 +2022,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 0, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PWild, loc), - strcat [(L'.ERel 1, loc), + ((L'.PVar ("_", disc), loc), + strcat [(L'.ERel 2, loc), str ", ", - (L'.ERel 0, loc)])], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + (L'.ERel 1, loc)])], + {disc = disc, result = s}), loc)), loc)), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), @@ -2043,23 +2044,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 1, loc)), ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc), fm) end @@ -2067,6 +2068,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CRecord (_, right), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec right, (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2081,23 +2083,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " LEFT JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2105,6 +2107,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec left, (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2119,23 +2122,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " RIGHT JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2143,6 +2146,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CRecord (_, right), _)), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) in ((L'.EAbs ("_", outerRec (left @ right), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2157,23 +2161,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then [str "("] else []) - @ [(L'.ERel 2, loc), + @ [(L'.ERel 3, loc), str " FULL JOIN ", - (L'.ERel 1, loc), + (L'.ERel 2, loc), str " ON ", - (L'.ERel 0, loc)] + (L'.ERel 1, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then [str ")"] else [])))], - {disc = (L'.TRecord [("1", s), ("2", s)], loc), + {disc = disc, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2202,11 +2206,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc)]), - ((L'.PWild, loc), - strcat [(L'.ERel 2, loc), - (L'.ERel 1, loc), + ((L'.PVar ("_", s), loc), + strcat [(L'.ERel 3, loc), + (L'.ERel 2, loc), str ", ", - (L'.ERel 0, loc)])], + (L'.ERel 1, loc)])], {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), fm) end @@ -2312,13 +2316,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val s = (L'.TFfi ("Basis", "string"), loc) - val default = strcat [str "(", - (L'.ERel 1, loc), - str " ", - (L'.ERel 2, loc), - str " ", - (L'.ERel 0, loc), - str ")"] + fun default n = strcat [str "(", + (L'.ERel (n + 1), loc), + str " ", + (L'.ERel (n + 2), loc), + str " ", + (L'.ERel n, loc), + str ")"] val body = case #1 arg1 of L.CApp ((L.CFfi ("Basis", "option"), _), _) => @@ -2335,11 +2339,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = str ") IS NULL AND (", (L'.ERel 0, loc), str ") IS NULL))"]), - ((L'.PWild, loc), - default)], + ((L'.PVar ("_", s), loc), + default 1)], {disc = s, result = s}), loc) - | _ => default + | _ => default 0 in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), @@ -2393,6 +2397,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TFfi ("Basis", "bool"), loc) in (if #nestedRelops (Settings.currentDbms ()) then (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), @@ -2409,9 +2414,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), str " ALL"), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), str "")], - {disc = (L'.TFfi ("Basis", "bool"), loc), + {disc = disc, result = s}), loc), str " (", (L'.ERel 0, loc), @@ -2430,9 +2435,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), str " ALL"), - ((L'.PWild, loc), + ((L'.PVar ("_", disc), loc), str "")], - {disc = (L'.TFfi ("Basis", "bool"), loc), + {disc = disc, result = s}), loc), str " ", (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), @@ -2773,9 +2778,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase ((L'.ERel 0, loc), [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), - ((L'.PWild, loc), + ((L'.PVar ("_", s), loc), strcat [str " ORDER BY ", - (L'.ERel 0, loc)])], + (L'.ERel 1, loc)])], {disc = s, result = s}), loc), str ")"] diff --git a/src/reduce.sml b/src/reduce.sml index 0762a4a1..04cec168 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -148,8 +148,7 @@ fun match (env, p : pat, e : exp) = fun match (env, p, e) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) + (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) | (PPrim p, EPrim p') => if Prim.equal (p, p') then @@ -425,8 +424,7 @@ fun kindConAndExp (namedC, namedE) = fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBinds p @@ -757,14 +755,12 @@ fun kindConAndExp (namedC, namedE) = end | ECase (_, [((PRecord [], _), e)], _) => exp env e - | ECase (_, [((PWild, _), e)], _) => exp env e | ECase (e, pes, {disc, result}) => let fun pat (all as (p, loc)) = case p of - PWild => all - | PVar (x, t) => (PVar (x, con env t), loc) + PVar (x, t) => (PVar (x, con env t), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 6fbc6a96..06f49fef 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -62,8 +62,7 @@ fun match (env, p : pat, e : exp) = fun match (env, p, e) = case (#1 p, #1 e) of - (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env) + (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env) | (PPrim p, EPrim p') => if Prim.equal (p, p') then @@ -313,8 +312,7 @@ fun exp env (all as (e, loc)) = fun patBinds (p, _) = case p of - PWild => 0 - | PVar _ => 1 + PVar _ => 1 | PPrim _ => 0 | PCon (_, _, _, NONE) => 0 | PCon (_, _, _, SOME p) => patBinds p @@ -322,8 +320,7 @@ fun exp env (all as (e, loc)) = fun pat (all as (p, loc)) = case p of - PWild => all - | PVar (x, t) => (PVar (x, con env t), loc) + PVar (x, t) => (PVar (x, con env t), loc) | PPrim _ => all | PCon (dk, pc, cs, po) => (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) diff --git a/src/settings.sig b/src/settings.sig index 732a31fa..c75f12a3 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -238,6 +238,9 @@ signature SETTINGS = sig val setStaticLinking : bool -> unit val getStaticLinking : unit -> bool + val setBootLinking : bool -> unit + val getBootLinking : unit -> bool + val setDeadlines : bool -> unit val getDeadlines : unit -> bool diff --git a/src/settings.sml b/src/settings.sml index 94692a2e..38ea30fc 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -686,6 +686,10 @@ val staticLinking = ref false fun setStaticLinking b = staticLinking := b fun getStaticLinking () = !staticLinking +val bootLinking = ref false +fun setBootLinking b = bootLinking := b +fun getBootLinking () = !bootLinking + val deadlines = ref false fun setDeadlines b = deadlines := b fun getDeadlines () = !deadlines diff --git a/src/source.sml b/src/source.sml index 2a741dd9..9971ca93 100644 --- a/src/source.sml +++ b/src/source.sml @@ -104,8 +104,7 @@ and sgn' = | SgnProj of string * string list * string and pat' = - PWild - | PVar of string + PVar of string | PPrim of Prim.t | PCon of string list * string * pat option | PRecord of (string * pat) list * bool diff --git a/src/source_print.sml b/src/source_print.sml index db56a0db..7b657422 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -187,8 +187,7 @@ and p_name (all as (c, _)) = fun p_pat' par (p, _) = case p of - PWild => string "_" - | PVar s => string s + PVar s => string s | PPrim p => Prim.p_t p | PCon (ms, x, NONE) => p_list_sep (string ".") string (ms @ [x]) | PCon (ms, x, SOME p) => parenIf par (box [p_list_sep (string ".") string (ms @ [x]), diff --git a/src/specialize.sml b/src/specialize.sml index 5d8cef09..33545250 100644 --- a/src/specialize.sml +++ b/src/specialize.sml @@ -162,8 +162,7 @@ and specCon st = U.Con.foldMap {kind = kind, con = con} st fun pat (p, st) = case #1 p of - PWild => (p, st) - | PVar _ => (p, st) + PVar _ => (p, st) | PPrim _ => (p, st) | PCon (dk, PConVar pn, args as (_ :: _), po) => let diff --git a/src/termination.sml b/src/termination.sml index f0b21d99..f0ec46d8 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -107,8 +107,7 @@ fun declOk' env (d, loc) = | _ => foldl (fn ((_, pt', _), penv) => pat penv (Rabble, pt')) penv xps in case (p, pt) of - (_, PWild) => penv - | (_, PVar _) => p :: penv + (_, PVar _) => p :: penv | (_, PPrim _) => penv | (_, PCon (_, _, _, NONE)) => penv | (Arg (i, j, _), PCon (_, pc, _, SOME pt')) => con (i, j, pc, pt') diff --git a/src/unnest.sml b/src/unnest.sml index 3034eb6e..7469ffd4 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -256,8 +256,7 @@ fun exp ((ns, ks, ts), e as old, st : state) = fun doVars ((p, _), ts) = case p of - PWild => ts - | PVar xt => xt :: ts + PVar xt => xt :: ts | PPrim _ => ts | PCon (_, _, _, NONE) => ts | PCon (_, _, _, SOME p) => doVars (p, ts) diff --git a/src/urweb.grm b/src/urweb.grm index 50dacf21..0f499e20 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -335,7 +335,7 @@ fun applyWindow loc e window = fun patternOut (e : exp) = case #1 e of - EWild => (PWild, #2 e) + EWild => (PVar "_", #2 e) | EVar ([], x, Infer) => if Char.isUpper (String.sub (x, 0)) then (PCon ([], x, NONE), #2 e) @@ -346,7 +346,7 @@ fun patternOut (e : exp) = (PCon (xs, x, NONE), #2 e) else (ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern"; - (PWild, #2 e)) + (PVar "_", #2 e)) | EPrim p => (PPrim p, #2 e) | EApp ((EVar (xs, x, Infer), _), e') => (PCon (xs, x, SOME (patternOut e')), #2 e) @@ -364,7 +364,7 @@ fun patternOut (e : exp) = | EAnnot (e', t) => (PAnnot (patternOut e', t), #2 e) | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern."; - (PWild, #2 e)) + (PVar "_", #2 e)) %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -1543,7 +1543,7 @@ pat : patS (patS) pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) - | UNDER (PWild, s (UNDERleft, UNDERright)) + | UNDER (PVar "_", s (UNDERleft, UNDERright)) | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) |