diff --git a/Makefile b/Makefile index 8da4bd0c..d8fab108 100644 --- a/Makefile +++ b/Makefile @@ -64,7 +64,7 @@ sources = \ src/main-default.sml typecheck: src/lunarml.mlb $(sources) - mlton -stop tc $< + mlton -stop tc -default-ann "warnUnused true" $< bin/lunarml: src/lunarml.mlb $(sources) mlton -output $@ $< diff --git a/pluto/parser-combinator.fun b/pluto/parser-combinator.fun index 7fa583da..72035172 100644 --- a/pluto/parser-combinator.fun +++ b/pluto/parser-combinator.fun @@ -23,14 +23,14 @@ fun showError ({ pos, messages } : parseError) = S.showPos pos ^ ": " ^ String.c | Expected s => "expected " ^ s | Unexpected s => "unexpected " ^ s ) messages) -datatype 'a parserResult = Ok' of 'a * bool * internalState - | Err of bool * parseError +datatype 'a parserResult = Ok' of 'a * (* consumed? *) bool * internalState + | Err of (* consumed? *) bool * parseError type 'a parser = internalState -> 'a parserResult datatype 'a result = ParseError of string | Ok of 'a * state fun runParser p state0 name stream = case p { stream = stream, pos = Stream.initialPos name, user = state0 } of - Ok' (result, consumed, { stream, pos, user }) => Ok (result, user) - | Err (consumed, e) => ParseError (showError e) + Ok' (result, _, { stream = _, pos = _, user }) => Ok (result, user) + | Err (_, e) => ParseError (showError e) fun delay p = fn s => p () s fun fix f = let fun p s = f p s in p @@ -114,7 +114,7 @@ fun many p = fn s => case p s of Ok' (xs, _, s) => Ok' (x :: xs, true, s) | Err (_, e) => Err (true, e) ) - | Ok' (x, false, s) => Err (false, { pos = #pos s, messages = [Message "many: combinator 'many' is applied to a parser that accepts an empty string"] }) + | Ok' (_, false, s) => Err (false, { pos = #pos s, messages = [Message "many: combinator 'many' is applied to a parser that accepts an empty string"] }) | Err (false, _) => Ok' ([], false, s) | Err (true, e) => Err (true, e) (* fun many p = (p >>= (fn x => many p >>= (fn xs => pure (x :: xs)))) <|> pure [] *) @@ -133,7 +133,7 @@ fun optional_ p = fn s => case p s of | Err (false, _) => Ok' ((), false, s) | Err (true, e) => Err (true, e) fun notFollowedBy p = fn s => case p s of - Ok' (x, _, _) => Err (false, { pos = #pos s, messages = [Unexpected "token"] }) (* unexpected 'x' *) + Ok' (_, _, _) => Err (false, { pos = #pos s, messages = [Unexpected "token"] }) (* unexpected 'x' *) | Err (_, _) => Ok' ((), false, s) val eof = notFollowedBy anyToken "end of input" fun between (open_, close) p = (open_ >> p) <* close diff --git a/src/codegen-js.sml b/src/codegen-js.sml index 0fa2c472..f5ac2c07 100644 --- a/src/codegen-js.sml +++ b/src/codegen-js.sml @@ -40,7 +40,6 @@ structure F = FSyntax structure C = CSyntax structure J = JsSyntax -fun LetStat (vid, exp) = J.LetStat (vector [(vid, SOME exp)]) fun ConstStat (vid, exp) = J.ConstStat (vector [(vid, exp)]) val builtinsDirect @@ -168,7 +167,7 @@ fun doValue (ctx, env : Env) (C.Var vid) = (case TypedSyntax.VIdMap.find (#subst | doValue _ C.Nil = J.ConstExp J.Null (* empty list *) | doValue _ (C.BoolConst false) = J.ConstExp J.False | doValue _ (C.BoolConst true) = J.ConstExp J.True - | doValue _ (C.IntConst (Primitives.INT, x)) = raise Fail "NativeIntConst is not supported by JavaScript backend" + | doValue _ (C.IntConst (Primitives.INT, _)) = raise Fail "NativeIntConst is not supported by JavaScript backend" | doValue _ (C.IntConst (Primitives.I32, x)) = if x < 0 then J.UnaryExp (J.NEGATE, J.ConstExp (J.Numeral (LargeInt.toString (~ x)))) else @@ -185,7 +184,7 @@ fun doValue (ctx, env : Env) (C.Var vid) = (case TypedSyntax.VIdMap.find (#subst J.UnaryExp (J.NEGATE, J.ConstExp (J.Numeral (LargeInt.toString (~ x) ^ "n"))) else J.ConstExp (J.Numeral (LargeInt.toString x ^ "n")) - | doValue _ (C.WordConst (Primitives.WORD, x)) = raise Fail "NativeWordConst is not supported by JavaScript backend" + | doValue _ (C.WordConst (Primitives.WORD, _)) = raise Fail "NativeWordConst is not supported by JavaScript backend" | doValue _ (C.WordConst (Primitives.W32, x)) = J.ConstExp (J.Numeral ("0x" ^ LargeInt.fmt StringCvt.HEX x)) | doValue _ (C.WordConst (Primitives.W64, x)) = J.ConstExp (J.Numeral ("0x" ^ LargeInt.fmt StringCvt.HEX x ^ "n")) | doValue _ (C.CharConst x) = J.ConstExp (J.Numeral (Int.toString (ord x))) @@ -207,12 +206,14 @@ fun genSymNamed (ctx : Context, name) = let val n = !(#nextJsId ctx) in TypedSyntax.MkVId (name, n) end fun genSym ctx = genSymNamed (ctx, "tmp") +(* fun genExnContSym (ctx : Context) = let val n = !(#nextJsId ctx) val _ = #nextJsId ctx := n + 1 in CSyntax.CVar.fromInt n end +*) -fun applyCont (ctx : Context, env : Env, cont, args) +fun applyCont (_ : Context, env : Env, cont, args) = case C.CVarMap.find (#continuations env, cont) of SOME (BREAK_TO { label, which, params }) => let val (params', args') = ListPair.foldrEq (fn (SOME p, a, (pp, aa)) => (p :: pp, a :: aa) | (NONE, _, acc) => acc @@ -242,9 +243,9 @@ fun doDecs (ctx, env, decs, finalExp, revStats) = (case VectorSlice.getItem decs of NONE => List.revAppend (revStats, doCExp ctx env finalExp) | SOME (dec, decs) => - let fun pure (NONE, exp) = doDecs (ctx, env, decs, finalExp, revStats) + let fun pure (NONE, _) = doDecs (ctx, env, decs, finalExp, revStats) | pure (SOME result, exp) = doDecs (ctx, env, decs, finalExp, ConstStat (result, exp) :: revStats) - fun discardable (NONE, exp) = doDecs (ctx, env, decs, finalExp, revStats) + fun discardable (NONE, _) = doDecs (ctx, env, decs, finalExp, revStats) | discardable (SOME result, exp) = doDecs (ctx, env, decs, finalExp, ConstStat (result, exp) :: revStats) fun impure (NONE, exp) = doDecs (ctx, env, decs, finalExp, J.ExpStat exp :: revStats) | impure (SOME result, exp) = doDecs (ctx, env, decs, finalExp, ConstStat (result, exp) :: revStats) @@ -308,13 +309,10 @@ fun doDecs (ctx, env, decs, finalExp, revStats) val payload = doValue (ctx, env) payload in pure (result, J.NewExp (tag, vector [payload])) end - | C.ValDec { exp = C.PrimOp { primOp = F.RaiseOp (span as { start as { file, line, column }, ... }), tyargs = _, args = [exp] }, result } => + | C.ValDec { exp = C.PrimOp { primOp = F.RaiseOp (_ (* span as { start as { file, line, column }, ... } *)), tyargs = _, args = [exp] }, result = _ } => List.rev (J.ThrowStat (doValue (ctx, env) exp) :: revStats) (* TODO: location information *) - | C.ValDec { exp = C.PrimOp { primOp = F.PrimCall prim, tyargs, args }, result } => - let fun ConstStatOrExpStat e = case result of - SOME result => ConstStat (result, e) - | NONE => J.ExpStat e - fun doNullary f = case args of + | C.ValDec { exp = C.PrimOp { primOp = F.PrimCall prim, tyargs = _, args }, result } => + let fun doNullary f = case args of [] => f () | _ => raise CodeGenError ("primop " ^ Primitives.toString prim ^ ": invalid number of arguments") fun doNullaryExp (f, purity) = doNullary (fn () => @@ -530,12 +528,12 @@ fun doDecs (ctx, env, decs, finalExp, revStats) impure (result, J.CallExp (J.IndexExp (doValue (ctx, env) obj, doValue (ctx, env) name), Vector.map (doValue (ctx, env)) (vector args))) | C.ValDec { exp = C.PrimOp { primOp = F.JsNewOp, tyargs = _, args = ctor :: args }, result } => impure (result, J.NewExp (doValue (ctx, env) ctor, Vector.map (doValue (ctx, env)) (vector args))) - | C.ValDec { exp = C.PrimOp { primOp, tyargs = _, args = _ }, result } => + | C.ValDec { exp = C.PrimOp { primOp, tyargs = _, args = _ }, result = _ } => raise CodeGenError ("primop " ^ Printer.build (FPrinter.doPrimOp primOp) ^ " is not supported on JavaScript backend") | C.ValDec { exp = C.Record fields, result } => let val fields = Syntax.LabelMap.foldri (fn (label, v, acc) => (label, doValue (ctx, env) v) :: acc) [] fields fun isTuple (_, []) = true - | isTuple (i, (Syntax.NumericLabel n, x) :: xs) = i = n andalso isTuple (i + 1, xs) + | isTuple (i, (Syntax.NumericLabel n, _) :: xs) = i = n andalso isTuple (i + 1, xs) | isTuple _ = false val exp = if isTuple (1, fields) then J.ArrayExp (vector (List.map #2 fields)) @@ -557,7 +555,7 @@ fun doDecs (ctx, env, decs, finalExp, revStats) end | NONE => doDecs (ctx, env, decs, finalExp, revStats) ) - | C.ValDec { exp = C.Projection { label, record, fieldTypes }, result } => + | C.ValDec { exp = C.Projection { label, record, fieldTypes = _ }, result } => let val label = case label of Syntax.NumericLabel n => J.ConstExp (J.Numeral (Int.toString (n - 1))) (* non-negative *) | Syntax.IdentifierLabel s => J.ConstExp (J.asciiStringAsWide s) @@ -641,7 +639,7 @@ fun doDecs (ctx, env, decs, finalExp, revStats) DIRECT_STYLE => false | CPS => List.exists (fn (name, _, _) => CpsAnalyze.escapesTransitively (#contEscapeMap ctx, name)) defs in if escape then - let val env' = { continuations = List.foldl (fn ((name, params, _), e) => C.CVarMap.insert (e, name, TAILCALL name)) (#continuations env) defs + let val env' = { continuations = List.foldl (fn ((name, _, _), e) => C.CVarMap.insert (e, name, TAILCALL name)) (#continuations env) defs , subst = #subst env } val (decs', assignments) = List.foldr (fn ((name, params, body), (decs, assignments)) => @@ -654,7 +652,7 @@ fun doDecs (ctx, env, decs, finalExp, revStats) | NO_INIT val init = case (VectorSlice.isEmpty decs, finalExp) of (true, C.AppCont { applied, args }) => - let fun find (i, []) = NO_INIT + let fun find (_, []) = NO_INIT | find (i, (name, params, _) :: xs) = if name = applied then INIT_WITH_VALUES (i, params, args) else @@ -667,7 +665,7 @@ fun doDecs (ctx, env, decs, finalExp, revStats) | NO_WHICH of C.CVar * (C.Var option) list * C.CExp val maxargs = List.foldl (fn ((_, params, _), n) => Int.max (n, List.length (List.filter Option.isSome params))) 0 defs val commonParams = List.tabulate (maxargs, fn _ => genSym ctx) - fun mapCommonParams params = List.rev (#2 (List.foldl (fn (SOME p, (c :: rest, acc)) => (rest, SOME c :: acc) + fun mapCommonParams params = List.rev (#2 (List.foldl (fn (SOME _, (c :: rest, acc)) => (rest, SOME c :: acc) | (_, (rest, acc)) => (rest, NONE :: acc) ) (commonParams, []) params)) val (optWhich, vars) = case defs of @@ -719,7 +717,7 @@ fun doDecs (ctx, env, decs, finalExp, revStats) , initAndRest @ [ J.LoopStat ( SOME loopLabel , case optWhich of - NO_WHICH (name, params, body) => + NO_WHICH (_, params, body) => let val dec = let val defs = ListPair.map (fn (p, c) => (p, J.VarExp (J.UserDefinedId c))) (List.mapPartial (fn x => x) params, commonParams) in if List.null defs then [] @@ -730,7 +728,7 @@ fun doDecs (ctx, env, decs, finalExp, revStats) end | NEED_WHICH which' => vector [ J.SwitchStat ( J.VarExp which' - , #2 (List.foldr (fn ((name, params, body), (i, cases)) => + , #2 (List.foldr (fn ((_, params, body), (i, cases)) => let val i = i - 1 val dec = let val defs = ListPair.map (fn (p, c) => (p, J.VarExp (J.UserDefinedId c))) (List.mapPartial (fn x => x) params, commonParams) in if List.null defs then @@ -834,7 +832,7 @@ and doCExp (ctx : Context) (env : Env) (C.Let { decs, cont }) : J.Stat list end end ) - | doCExp ctx env C.Unreachable = [] + | doCExp _ _ C.Unreachable = [] fun doProgramDirect ctx cont cexp = let val label = CVarToJs cont diff --git a/src/codegen-lua.sml b/src/codegen-lua.sml index 9541b650..d948a4c4 100644 --- a/src/codegen-lua.sml +++ b/src/codegen-lua.sml @@ -187,7 +187,7 @@ type Env = { continuations : cont_type C.CVarMap.map datatype purity = PURE | DISCARDABLE | IMPURE -fun applyCont (ctx : Context, env : Env, defaultCont : C.CVar option, cont : C.CVar, args : L.Exp list) +fun applyCont (_ : Context, env : Env, defaultCont : C.CVar option, cont : C.CVar, args : L.Exp list) = case C.CVarMap.find (#continuations env, cont) of SOME (GOTO { label, params = [] }) => if defaultCont = SOME cont then [] @@ -215,25 +215,25 @@ fun doValue ctx (C.Var vid) = (case VIdToLua (ctx, vid) of | L.PredefinedId "true" => L.ConstExp L.True | id => L.VarExp id ) - | doValue ctx C.Unit = L.ConstExp L.Nil - | doValue ctx C.Nil = L.ConstExp L.Nil (* empty list *) - | doValue ctx (C.BoolConst false) = L.ConstExp L.False - | doValue ctx (C.BoolConst true) = L.ConstExp L.True - | doValue ctx (C.IntConst (Primitives.INT, x)) = if x < 0 then - if x = ~0x8000000000000000 then - L.BinExp (L.MINUS, L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ (x + 1))))), L.ConstExp (L.Numeral "1")) - else - L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ x)))) - else - L.ConstExp (L.Numeral (LargeInt.toString x)) - | doValue ctx (C.IntConst (Primitives.I32, x)) = if x < 0 then - L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ x)))) - else - L.ConstExp (L.Numeral (LargeInt.toString x)) - | doValue ctx (C.IntConst (Primitives.I54, x)) = if x < 0 then - L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ x)))) - else - L.ConstExp (L.Numeral (LargeInt.toString x)) + | doValue _ C.Unit = L.ConstExp L.Nil + | doValue _ C.Nil = L.ConstExp L.Nil (* empty list *) + | doValue _ (C.BoolConst false) = L.ConstExp L.False + | doValue _ (C.BoolConst true) = L.ConstExp L.True + | doValue _ (C.IntConst (Primitives.INT, x)) = if x < 0 then + if x = ~0x8000000000000000 then + L.BinExp (L.MINUS, L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ (x + 1))))), L.ConstExp (L.Numeral "1")) + else + L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ x)))) + else + L.ConstExp (L.Numeral (LargeInt.toString x)) + | doValue _ (C.IntConst (Primitives.I32, x)) = if x < 0 then + L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ x)))) + else + L.ConstExp (L.Numeral (LargeInt.toString x)) + | doValue _ (C.IntConst (Primitives.I54, x)) = if x < 0 then + L.UnaryExp (L.NEGATE, L.ConstExp (L.Numeral (LargeInt.toString (~ x)))) + else + L.ConstExp (L.Numeral (LargeInt.toString x)) | doValue ctx (C.IntConst (Primitives.I64, x)) = let val suffix = case #targetLuaVersion ctx of LUA5_3 => "" | LUAJIT => "LL" @@ -245,18 +245,18 @@ fun doValue ctx (C.Var vid) = (case VIdToLua (ctx, vid) of else L.ConstExp (L.Numeral (LargeInt.toString x ^ suffix)) end - | doValue ctx (C.IntConst (Primitives.INT_INF, x)) = raise CodeGenError "IntInf is not natively supported by Lua backend" - | doValue ctx (C.WordConst (Primitives.WORD, x)) = L.ConstExp (L.Numeral ("0x" ^ LargeInt.fmt StringCvt.HEX x)) - | doValue ctx (C.WordConst (Primitives.W32, x)) = L.ConstExp (L.Numeral ("0x" ^ LargeInt.fmt StringCvt.HEX x)) + | doValue _ (C.IntConst (Primitives.INT_INF, _)) = raise CodeGenError "IntInf is not natively supported by Lua backend" + | doValue _ (C.WordConst (Primitives.WORD, x)) = L.ConstExp (L.Numeral ("0x" ^ LargeInt.fmt StringCvt.HEX x)) + | doValue _ (C.WordConst (Primitives.W32, x)) = L.ConstExp (L.Numeral ("0x" ^ LargeInt.fmt StringCvt.HEX x)) | doValue ctx (C.WordConst (Primitives.W64, x)) = let val suffix = case #targetLuaVersion ctx of LUA5_3 => "" | LUAJIT => "ULL" in L.ConstExp (L.Numeral ("0x" ^ LargeInt.fmt StringCvt.HEX x ^ suffix)) end - | doValue ctx (C.CharConst c) = L.ConstExp (L.Numeral (Int.toString (Char.ord c))) - | doValue ctx (C.Char16Const _) = raise CodeGenError "Char16Const is not supported by Lua backend" - | doValue ctx (C.StringConst s) = L.ConstExp (L.LiteralString s) - | doValue ctx (C.String16Const _) = raise CodeGenError "String16Const is not supported by Lua backend" + | doValue _ (C.CharConst c) = L.ConstExp (L.Numeral (Int.toString (Char.ord c))) + | doValue _ (C.Char16Const _) = raise CodeGenError "Char16Const is not supported by Lua backend" + | doValue _ (C.StringConst s) = L.ConstExp (L.LiteralString s) + | doValue _ (C.String16Const _) = raise CodeGenError "String16Const is not supported by Lua backend" (*: val doDecs : Context * Env * C.CVar option * C.Dec VectorSlice.slice * C.CExp * L.Stat list -> L.Stat list @@ -266,9 +266,9 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) = (case VectorSlice.getItem decs of NONE => List.revAppend (revStats, doCExp (ctx, env, defaultCont, finalExp)) | SOME (dec, decs) => - let fun pure (NONE, exp) = doDecs (ctx, env, defaultCont, decs, finalExp, revStats) + let fun pure (NONE, _) = doDecs (ctx, env, defaultCont, decs, finalExp, revStats) | pure (SOME result, exp) = doDecs (ctx, env, defaultCont, decs, finalExp, L.ConstStat (result, exp) :: revStats) - fun discardable (NONE, exp) = doDecs (ctx, env, defaultCont, decs, finalExp, revStats) + fun discardable (NONE, _) = doDecs (ctx, env, defaultCont, decs, finalExp, revStats) | discardable (SOME result, exp) = doDecs (ctx, env, defaultCont, decs, finalExp, L.ConstStat (result, exp) :: revStats) fun impure (NONE, exp) = doDecs (ctx, env, defaultCont, decs, finalExp, List.revAppend (ExpStat exp, revStats)) | impure (SOME result, exp) = doDecs (ctx, env, defaultCont, decs, finalExp, L.ConstStat (result, exp) :: revStats) @@ -287,12 +287,12 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) | C.ValDec { exp = C.PrimOp { primOp = F.ListOp, tyargs = _, args = [] }, result } => pure (result, L.ConstExp L.Nil) | C.ValDec { exp = C.PrimOp { primOp = F.ListOp, tyargs = _, args = xs }, result } => - let fun doFields (i, []) = [] + let fun doFields (_, []) = [] | doFields (i, y :: ys) = (L.IntKey i, doValue ctx y) :: doFields (i + 1, ys) in pure (result, L.CallExp (L.VarExp (L.PredefinedId "_list"), vector [L.TableExp (vector ((L.StringKey "n", L.ConstExp (L.Numeral (Int.toString (List.length xs)))) :: doFields (1, xs)))])) end | C.ValDec { exp = C.PrimOp { primOp = F.VectorOp, tyargs = _, args = xs }, result } => - let fun doFields (i, []) = [] + let fun doFields (_, []) = [] | doFields (i, y :: ys) = (L.IntKey i, doValue ctx y) :: doFields (i + 1, ys) in pure (result, L.TableExp (vector ((L.StringKey "n", L.ConstExp (L.Numeral (Int.toString (List.length xs)))) :: doFields (1, xs)))) end @@ -335,7 +335,7 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) val payload = doValue ctx payload in pure (result, L.TableExp (vector [(L.StringKey "tag", tag), (L.StringKey "payload", payload)])) end - | C.ValDec { exp = C.PrimOp { primOp = F.RaiseOp (span as { start as { file, line, column }, ... }), tyargs = _, args = [exp] }, result } => + | C.ValDec { exp = C.PrimOp { primOp = F.RaiseOp ({ start as { file, line, column }, ... }), tyargs = _, args = [exp] }, result = _ } => let val exp = doValue ctx exp val locationInfo = if start = SourcePos.nullPos then L.ConstExp L.Nil @@ -343,7 +343,7 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) L.ConstExp (L.LiteralString (OS.Path.file file ^ ":" ^ Int.toString line ^ ":" ^ Int.toString column)) in List.rev (L.CallStat (L.VarExp (L.PredefinedId "_raise"), vector [exp, locationInfo]) :: revStats) (* discard continuation *) end - | C.ValDec { exp = C.PrimOp { primOp = F.PrimCall prim, tyargs, args }, result } => + | C.ValDec { exp = C.PrimOp { primOp = F.PrimCall prim, tyargs = _, args }, result } => let fun doUnary f = case args of [a] => f (doValue ctx a) | _ => raise CodeGenError ("primop " ^ Primitives.toString prim ^ ": invalid number of arguments") @@ -520,7 +520,7 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) | (LUAJIT, Primitives.I64, Primitives.I54) => doUnaryExp (fn a => L.CallExp (L.VarExp (L.PredefinedId "tonumber"), vector [a]), PURE) | _ => raise CodeGenError ("primop " ^ Primitives.toString prim ^ " is not supported on this target") ) - | Primitives.Word_EQUAL w => doBinaryOp (L.EQUAL, PURE) + | Primitives.Word_EQUAL _ => doBinaryOp (L.EQUAL, PURE) | Primitives.Word_PLUS w => (case (#targetLuaVersion ctx, w) of (LUA5_3, Primitives.WORD) => doBinaryOp (L.PLUS, PURE) @@ -834,21 +834,21 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) NONE => doDecs (ctx, env, defaultCont, decs, finalExp, L.MethodStat (doValue ctx obj, name, Vector.map (doValue ctx) (vector args)) :: revStats) | SOME result => doDecs (ctx, env, defaultCont, decs, finalExp, L.ConstStat (result, L.CallExp (L.VarExp (L.PredefinedId "table_pack"), vector [L.MethodExp (doValue ctx obj, name, Vector.map (doValue ctx) (vector args))])) :: revStats) ) - | C.ValDec { exp = C.PrimOp { primOp = F.JsCallOp, tyargs = _, args = _ }, result } => + | C.ValDec { exp = C.PrimOp { primOp = F.JsCallOp, tyargs = _, args = _ }, result = _ } => raise CodeGenError "JsCallOp is not supported on Lua backend" - | C.ValDec { exp = C.PrimOp { primOp = F.JsMethodOp, tyargs = _, args = _ }, result } => + | C.ValDec { exp = C.PrimOp { primOp = F.JsMethodOp, tyargs = _, args = _ }, result = _ } => raise CodeGenError "JsMethodOp is not supported on Lua backend" - | C.ValDec { exp = C.PrimOp { primOp = F.JsNewOp, tyargs = _, args = _ }, result } => + | C.ValDec { exp = C.PrimOp { primOp = F.JsNewOp, tyargs = _, args = _ }, result = _ } => raise CodeGenError "JsNewOp is not supported on Lua backend" - | C.ValDec { exp = C.PrimOp { primOp, tyargs = _, args = _ }, result } => + | C.ValDec { exp = C.PrimOp { primOp, tyargs = _, args = _ }, result = _ } => raise CodeGenError ("primop " ^ Printer.build (FPrinter.doPrimOp primOp) ^ " not implemented yet") | C.ValDec { exp = C.Record fields, result } => (* non-empty record *) let val fields = Syntax.LabelMap.foldri (fn (label, v, acc) => (LabelToTableKey label, doValue ctx v) :: acc) [] fields in pure (result, L.TableExp (vector fields)) end - | C.ValDec { exp = C.ExnTag { name, payloadTy }, result } => + | C.ValDec { exp = C.ExnTag { name, payloadTy = _ }, result } => discardable (result, L.TableExp (vector [(L.IntKey 1, L.ConstExp (L.LiteralString name))])) - | C.ValDec { exp = C.Projection { label, record, fieldTypes }, result } => + | C.ValDec { exp = C.Projection { label, record, fieldTypes = _ }, result } => let val label = case label of Syntax.NumericLabel n => L.ConstExp (L.Numeral (Int.toString n)) | Syntax.IdentifierLabel s => L.ConstExp (L.LiteralString s) @@ -899,10 +899,10 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) | _ => NO_INIT val maxParams = List.foldl (fn ((_, params, _), n) => Int.max (n, List.length (List.filter Option.isSome params))) 0 defs val commonParams = List.tabulate (maxParams, fn _ => genSym ctx) - fun mapCommonParams params = List.rev (#2 (List.foldl (fn (SOME p, (c :: rest, acc)) => (rest, SOME c :: acc) + fun mapCommonParams params = List.rev (#2 (List.foldl (fn (SOME _, (c :: rest, acc)) => (rest, SOME c :: acc) | (_, (rest, acc)) => (rest, NONE :: acc) ) (commonParams, []) params)) - val env' = { continuations = List.foldl (fn ((name, params, body), m) => + val env' = { continuations = List.foldl (fn ((name, params, _), m) => C.CVarMap.insert (m, name, GOTO { label = doLabel name , params = List.map (Option.map L.UserDefinedId) (mapCommonParams params) } @@ -945,7 +945,7 @@ fun doDecs (ctx, env, defaultCont, decs, finalExp, revStats : L.Stat list) ) and doCExp (ctx : Context, env : Env, defaultCont : C.CVar option, C.Let { decs, cont }) = doDecs (ctx, env, defaultCont, VectorSlice.full decs, cont, []) - | doCExp (ctx, env, defaultCont, C.App { applied, cont, args }) + | doCExp (ctx, env, _, C.App { applied, cont, args }) = (case C.CVarMap.find (#continuations env, cont) of SOME (GOTO { label, params }) => let val callAndAssign = if List.exists Option.isSome params then @@ -1001,7 +1001,7 @@ and doCExp (ctx : Context, env : Env, defaultCont : C.CVar option, C.Let { decs, ) ] end - | doCExp (ctx, env, defaultCont, C.Unreachable) = [] + | doCExp (_, _, _, C.Unreachable) = [] fun doProgram ctx cont cexp = let val env = { continuations = C.CVarMap.singleton (cont, RETURN) } diff --git a/src/cps.sml b/src/cps.sml index 708d5551..aca270b5 100644 --- a/src/cps.sml +++ b/src/cps.sml @@ -53,7 +53,6 @@ structure CSyntax :> sig end = struct exception InvalidCode of string type Var = TypedSyntax.VId -type Tag = string structure CVar :> sig eqtype t type ord_key = t @@ -139,7 +138,7 @@ fun isDiscardable (PrimOp { primOp = F.IntConstOp _, ... }) = true | isDiscardable (ExnTag _) = true | isDiscardable (Projection _) = true | isDiscardable (Abs _) = true -fun mayRaise (PrimOp { primOp, ... }) = (case primOp of +(* fun mayRaise (PrimOp { primOp, ... }) = (case primOp of F.IntConstOp _ => false | F.WordConstOp _ => false | F.RealConstOp _ => false @@ -169,17 +168,17 @@ fun mayRaise (PrimOp { primOp, ... }) = (case primOp of | mayRaise (Record _) = false | mayRaise (ExnTag _) = false | mayRaise (Projection _) = false - | mayRaise (Abs _) = false + | mayRaise (Abs _) = false *) fun containsAppDec (ValDec _) = false | containsAppDec (RecDec _) = false - | containsAppDec (ContDec { name, params, body }) = containsApp body + | containsAppDec (ContDec { name = _, params = _, body }) = containsApp body | containsAppDec (RecContDec defs) = List.exists (fn (_, _, body) => containsApp body) defs | containsAppDec (ESImportDec _) = false and containsApp (Let { decs, cont }) = containsApp cont orelse Vector.exists containsAppDec decs | containsApp (App _) = true | containsApp (AppCont _) = false - | containsApp (If { cond, thenCont, elseCont }) = containsApp thenCont orelse containsApp elseCont + | containsApp (If { cond = _, thenCont, elseCont }) = containsApp thenCont orelse containsApp elseCont | containsApp (Handle { body, handler = (_, h), ... }) = containsApp body orelse containsApp h | containsApp Unreachable = false @@ -200,13 +199,13 @@ fun freeVarsInValue bound (v, acc) | String16Const _ => acc fun VIdSet_addOpt (SOME x, set) = TypedSyntax.VIdSet.add (set, x) | VIdSet_addOpt (NONE, set) = set -fun freeVarsInSimpleExp (bound, PrimOp { primOp, tyargs = _, args }, acc) = List.foldl (freeVarsInValue bound) acc args +fun freeVarsInSimpleExp (bound, PrimOp { primOp = _, tyargs = _, args }, acc) = List.foldl (freeVarsInValue bound) acc args | freeVarsInSimpleExp (bound, Record fields, acc) = Syntax.LabelMap.foldl (freeVarsInValue bound) acc fields - | freeVarsInSimpleExp (bound, ExnTag { name, payloadTy }, acc) = acc - | freeVarsInSimpleExp (bound, Projection { label, record, fieldTypes }, acc) = freeVarsInValue bound (record, acc) - | freeVarsInSimpleExp (bound, Abs { contParam, params, body }, acc) = let val bound = List.foldl TypedSyntax.VIdSet.add' bound params - in freeVarsInExp (bound, body, acc) - end + | freeVarsInSimpleExp (_, ExnTag { name = _, payloadTy = _ }, acc) = acc + | freeVarsInSimpleExp (bound, Projection { label = _, record, fieldTypes = _ }, acc) = freeVarsInValue bound (record, acc) + | freeVarsInSimpleExp (bound, Abs { contParam = _, params, body }, acc) = let val bound = List.foldl TypedSyntax.VIdSet.add' bound params + in freeVarsInExp (bound, body, acc) + end and freeVarsInDec (ValDec { exp, result }, (bound, acc)) = let val acc = freeVarsInSimpleExp (bound, exp, acc) in case result of @@ -222,7 +221,7 @@ and freeVarsInDec (ValDec { exp, result }, (bound, acc)) ) acc defs in (bound, acc) end - | freeVarsInDec (ContDec { name, params, body }, (bound, acc)) + | freeVarsInDec (ContDec { name = _, params, body }, (bound, acc)) = let val bound = List.foldl VIdSet_addOpt bound params in (bound, freeVarsInExp (bound, body, acc)) end @@ -238,11 +237,11 @@ and freeVarsInDec (ValDec { exp, result }, (bound, acc)) and freeVarsInExp (bound, Let { decs, cont }, acc) = let val (bound, acc) = Vector.foldl freeVarsInDec (bound, acc) decs in freeVarsInExp (bound, cont, acc) end - | freeVarsInExp (bound, App { applied, cont, args }, acc) = List.foldl (freeVarsInValue bound) (freeVarsInValue bound (applied, acc)) args - | freeVarsInExp (bound, AppCont { applied, args }, acc) = List.foldl (freeVarsInValue bound) acc args + | freeVarsInExp (bound, App { applied, cont = _, args }, acc) = List.foldl (freeVarsInValue bound) (freeVarsInValue bound (applied, acc)) args + | freeVarsInExp (bound, AppCont { applied = _, args }, acc) = List.foldl (freeVarsInValue bound) acc args | freeVarsInExp (bound, If { cond, thenCont, elseCont }, acc) = freeVarsInExp (bound, elseCont, freeVarsInExp (bound, thenCont, freeVarsInValue bound (cond, acc))) - | freeVarsInExp (bound, Handle { body, handler = (e, h), successfulExitIn, successfulExitOut }, acc) = freeVarsInExp (bound, body, freeVarsInExp (TypedSyntax.VIdSet.add (bound, e), h, acc)) - | freeVarsInExp (bound, Unreachable, acc) = acc + | freeVarsInExp (bound, Handle { body, handler = (e, h), successfulExitIn = _, successfulExitOut = _ }, acc) = freeVarsInExp (bound, body, freeVarsInExp (TypedSyntax.VIdSet.add (bound, e), h, acc)) + | freeVarsInExp (_, Unreachable, acc) = acc fun recurseCExp f = let fun goSimpleExp (e as PrimOp _) = e @@ -309,7 +308,7 @@ datatype cont = REIFIED of C.CVar fun prependRevDecs ([], cont) = cont | prependRevDecs (revDecs, C.Let { decs, cont }) = C.Let { decs = Vector.fromList (List.revAppend (revDecs, Vector.foldr (op ::) [] decs)), cont = cont } | prependRevDecs (revDecs, cont) = C.Let { decs = Vector.fromList (List.rev revDecs), cont = cont } -fun reify (ctx, revDecs, REIFIED k) f = prependRevDecs (revDecs, f k) +fun reify (_, revDecs, REIFIED k) f = prependRevDecs (revDecs, f k) | reify (ctx, revDecs, META (hint, m)) f = let val k = genContSym ctx val x = case hint of NONE => genSym ctx @@ -339,7 +338,7 @@ fun transform (ctx, env) exp { revDecs, resultHint } k = transformX (ctx, env) e and transformT (ctx, env) exp (revDecs, k) = transformX (ctx, env) exp (revDecs, REIFIED k) and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : cont) : C.CExp = case exp of - F.PrimExp (F.PrimCall Primitives.DelimCont_pushPrompt, tyargs, [p (* 'a prompt_tag *), f (* unit -> 'a *)]) => + F.PrimExp (F.PrimCall Primitives.DelimCont_pushPrompt, _, [p (* 'a prompt_tag *), f (* unit -> 'a *)]) => transform (ctx, env) p { revDecs = revDecs, resultHint = NONE } (fn (revDecs, p) => transform (ctx, env) f { revDecs = revDecs, resultHint = NONE } @@ -350,7 +349,7 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con ) ) ) - | F.PrimExp (F.PrimCall Primitives.DelimCont_withSubCont, tyargs, [p (* 'b prompt_tag *), f (* ('a,'b) subcont -> 'b *)]) => + | F.PrimExp (F.PrimCall Primitives.DelimCont_withSubCont, _, [p (* 'b prompt_tag *), f (* ('a,'b) subcont -> 'b *)]) => transform (ctx, env) p { revDecs = revDecs, resultHint = NONE } (fn (revDecs, p) => transform (ctx, env) f { revDecs = revDecs, resultHint = NONE } @@ -361,7 +360,7 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con ) ) ) - | F.PrimExp (F.PrimCall Primitives.DelimCont_pushSubCont, tyargs, [subcont (* ('a,'b) subcont *), f (* unit -> 'a *)]) => + | F.PrimExp (F.PrimCall Primitives.DelimCont_pushSubCont, _, [subcont (* ('a,'b) subcont *), f (* unit -> 'a *)]) => transform (ctx, env) subcont { revDecs = revDecs, resultHint = NONE } (fn (revDecs, subcont) => transform (ctx, env) f { revDecs = revDecs, resultHint = NONE } @@ -372,7 +371,7 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con ) ) ) - | F.PrimExp (F.PrimCall Primitives.Unsafe_cast, tyargs, [arg]) => + | F.PrimExp (F.PrimCall Primitives.Unsafe_cast, _, [arg]) => transformX (ctx, env) arg (revDecs, k) | F.PrimExp (F.PrimCall Primitives.unreachable, _, _) => C.Unreachable @@ -552,7 +551,7 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con ) | F.TyAbsExp (_, _, exp) => transformX (ctx, env) exp (revDecs, k) | F.TyAppExp (exp, _) => transformX (ctx, env) exp (revDecs, k) - | F.PackExp { payloadTy, exp, packageTy } => transformX (ctx, env) exp (revDecs, k) + | F.PackExp { payloadTy = _, exp, packageTy = _ } => transformX (ctx, env) exp (revDecs, k) | F.BogusExp _ => raise Message.Abort | F.ExitProgram => (case k of REIFIED k => prependRevDecs (revDecs, C.AppCont { applied = k, args = [] }) @@ -576,7 +575,7 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con in prependRevDecs (dec :: revDecs, C.AppCont { applied = k, args = [C.Var result] }) end else - prependRevDecs (revDecs, C.AppCont { applied = k, args = List.foldl (fn ((name, v), acc) => v :: acc) [] items }) + prependRevDecs (revDecs, C.AppCont { applied = k, args = List.foldl (fn ((_, v), acc) => v :: acc) [] items }) ) | META _ => raise Fail "unexpected META" ) @@ -588,8 +587,7 @@ structure CpsDeadCodeAnalysis :> sig val analyze : CSyntax.CExp -> usage val isUsed : usage * TypedSyntax.VId -> bool end = struct -local structure F = FSyntax - structure C = CSyntax +local structure C = CSyntax in type graph = TypedSyntax.VIdSet.set TypedSyntax.VIdTable.hash_table type usage = bool TypedSyntax.VIdTable.hash_table @@ -603,11 +601,11 @@ fun addValue (C.Var v, set) = TypedSyntax.VIdSet.add (set, v) | addValue (C.Char16Const _, set) = set | addValue (C.StringConst _, set) = set | addValue (C.String16Const _, set) = set -fun goSimpleExp (g, C.PrimOp { primOp, tyargs = _, args }) = List.foldl addValue TypedSyntax.VIdSet.empty args - | goSimpleExp (g, C.Record fields) = Syntax.LabelMap.foldl addValue TypedSyntax.VIdSet.empty fields - | goSimpleExp (g, C.ExnTag { name, payloadTy }) = TypedSyntax.VIdSet.empty - | goSimpleExp (g, C.Projection { label, record, fieldTypes }) = addValue (record, TypedSyntax.VIdSet.empty) - | goSimpleExp (g, C.Abs { contParam, params, body }) = goExp (g, body, TypedSyntax.VIdSet.empty) (* What to do with params? *) +fun goSimpleExp (_, C.PrimOp { primOp = _, tyargs = _, args }) = List.foldl addValue TypedSyntax.VIdSet.empty args + | goSimpleExp (_, C.Record fields) = Syntax.LabelMap.foldl addValue TypedSyntax.VIdSet.empty fields + | goSimpleExp (_, C.ExnTag { name = _, payloadTy = _ }) = TypedSyntax.VIdSet.empty + | goSimpleExp (_, C.Projection { label = _, record, fieldTypes = _ }) = addValue (record, TypedSyntax.VIdSet.empty) + | goSimpleExp (g, C.Abs { contParam = _, params = _, body }) = goExp (g, body, TypedSyntax.VIdSet.empty) (* What to do with params? *) and goDec g (C.ValDec { exp, result }, acc) = let val s = goSimpleExp (g, exp) in case result of SOME r => TypedSyntax.VIdTable.insert g (r, s) @@ -621,17 +619,17 @@ and goDec g (C.ValDec { exp, result }, acc) = let val s = goSimpleExp (g, exp) in List.app (fn (name, _, _, _) => TypedSyntax.VIdTable.insert g (name, s)) defs ; acc end - | goDec g (C.ContDec { name, params, body }, acc) = goExp (g, body, acc) + | goDec g (C.ContDec { name = _, params = _, body }, acc) = goExp (g, body, acc) | goDec g (C.RecContDec defs, acc) = List.foldl (fn ((_, _, body), acc) => goExp (g, body, acc)) acc defs - | goDec g (C.ESImportDec { pure, specs, moduleName }, acc) = ( List.app (fn (_, vid) => TypedSyntax.VIdTable.insert g (vid, TypedSyntax.VIdSet.empty)) specs - ; acc - ) + | goDec g (C.ESImportDec { pure = _, specs, moduleName = _ }, acc) = ( List.app (fn (_, vid) => TypedSyntax.VIdTable.insert g (vid, TypedSyntax.VIdSet.empty)) specs + ; acc + ) and goExp (g, C.Let { decs, cont }, acc) = goExp (g, cont, Vector.foldl (goDec g) acc decs) - | goExp (g, C.App { applied, cont, args }, acc) = List.foldl addValue (addValue (applied, acc)) args - | goExp (g, C.AppCont { applied, args }, acc) = List.foldl addValue acc args + | goExp (_, C.App { applied, cont = _, args }, acc) = List.foldl addValue (addValue (applied, acc)) args + | goExp (_, C.AppCont { applied = _, args }, acc) = List.foldl addValue acc args | goExp (g, C.If { cond, thenCont, elseCont }, acc) = goExp (g, elseCont, goExp (g, thenCont, addValue (cond, acc))) - | goExp (g, C.Handle { body, handler = (e, h), successfulExitIn, successfulExitOut }, acc) = goExp (g, body, goExp (g, h, acc)) - | goExp (g, C.Unreachable, acc) = acc + | goExp (g, C.Handle { body, handler = (_, h), successfulExitIn = _, successfulExitOut = _ }, acc) = goExp (g, body, goExp (g, h, acc)) + | goExp (_, C.Unreachable, acc) = acc (*: val makeGraph : CSyntax.CExp -> graph * TypedSyntax.VIdSet.set *) fun makeGraph program = let val g = TypedSyntax.VIdTable.mkTable (1, Fail "dead code analysis table lookup failed") in (g, goExp (g, program, TypedSyntax.VIdSet.empty)) @@ -676,8 +674,7 @@ structure CpsUsageAnalysis :> sig , dead_code_analysis : CpsDeadCodeAnalysis.usage } end = struct -local structure F = FSyntax - structure C = CSyntax +local structure C = CSyntax in datatype frequency = NEVER | ONCE | MANY fun oneMore NEVER = ONCE @@ -708,15 +705,15 @@ fun useValue env (C.Var v) = (case TypedSyntax.VIdTable.find env v of end | NONE => () ) - | useValue env C.Unit = () - | useValue env C.Nil = () - | useValue env (C.BoolConst _) = () - | useValue env (C.IntConst _) = () - | useValue env (C.WordConst _) = () - | useValue env (C.CharConst _) = () - | useValue env (C.Char16Const _) = () - | useValue env (C.StringConst _) = () - | useValue env (C.String16Const _) = () + | useValue _ C.Unit = () + | useValue _ C.Nil = () + | useValue _ (C.BoolConst _) = () + | useValue _ (C.IntConst _) = () + | useValue _ (C.WordConst _) = () + | useValue _ (C.CharConst _) = () + | useValue _ (C.Char16Const _) = () + | useValue _ (C.StringConst _) = () + | useValue _ (C.String16Const _) = () fun useValueAsCallee (env, cont, C.Var v) = (case TypedSyntax.VIdTable.find env v of SOME r => let val { call, project, other, returnConts, labels } = !r @@ -724,15 +721,15 @@ fun useValueAsCallee (env, cont, C.Var v) end | NONE => () ) - | useValueAsCallee (env, cont, C.Unit) = () - | useValueAsCallee (env, cont, C.Nil) = () - | useValueAsCallee (env, cont, C.BoolConst _) = () - | useValueAsCallee (env, cont, C.IntConst _) = () - | useValueAsCallee (env, cont, C.WordConst _) = () - | useValueAsCallee (env, cont, C.CharConst _) = () - | useValueAsCallee (env, cont, C.Char16Const _) = () - | useValueAsCallee (env, cont, C.StringConst _) = () - | useValueAsCallee (env, cont, C.String16Const _) = () + | useValueAsCallee (_, _, C.Unit) = () + | useValueAsCallee (_, _, C.Nil) = () + | useValueAsCallee (_, _, C.BoolConst _) = () + | useValueAsCallee (_, _, C.IntConst _) = () + | useValueAsCallee (_, _, C.WordConst _) = () + | useValueAsCallee (_, _, C.CharConst _) = () + | useValueAsCallee (_, _, C.Char16Const _) = () + | useValueAsCallee (_, _, C.StringConst _) = () + | useValueAsCallee (_, _, C.String16Const _) = () fun useValueAsRecord (env, label, result, C.Var v) = (case TypedSyntax.VIdTable.find env v of SOME r => let val { call, project, other, returnConts, labels } = !r @@ -745,15 +742,15 @@ fun useValueAsRecord (env, label, result, C.Var v) end | NONE => () ) - | useValueAsRecord (env, label, result, C.Unit) = () - | useValueAsRecord (env, label, result, C.Nil) = () - | useValueAsRecord (env, label, result, C.BoolConst _) = () - | useValueAsRecord (env, label, result, C.IntConst _) = () - | useValueAsRecord (env, label, result, C.WordConst _) = () - | useValueAsRecord (env, label, result, C.CharConst _) = () - | useValueAsRecord (env, label, result, C.Char16Const _) = () - | useValueAsRecord (env, label, result, C.StringConst _) = () - | useValueAsRecord (env, label, result, C.String16Const _) = () + | useValueAsRecord (_, _, _, C.Unit) = () + | useValueAsRecord (_, _, _, C.Nil) = () + | useValueAsRecord (_, _, _, C.BoolConst _) = () + | useValueAsRecord (_, _, _, C.IntConst _) = () + | useValueAsRecord (_, _, _, C.WordConst _) = () + | useValueAsRecord (_, _, _, C.CharConst _) = () + | useValueAsRecord (_, _, _, C.Char16Const _) = () + | useValueAsRecord (_, _, _, C.StringConst _) = () + | useValueAsRecord (_, _, _, C.String16Const _) = () fun useContVarIndirect cenv (v : C.CVar) = (case C.CVarTable.find cenv v of SOME r => let val { direct, indirect } = !r in r := { direct = direct, indirect = oneMore indirect } @@ -776,10 +773,10 @@ local else C.CVarTable.insert cenv (v, ref neverUsedCont) in -fun goSimpleExp (env, renv, cenv, crenv, _, C.PrimOp { primOp = _, tyargs = _, args }) = List.app (useValue env) args - | goSimpleExp (env, renv, cenv, crenv, _, C.Record fields) = Syntax.LabelMap.app (useValue env) fields - | goSimpleExp (env, renv, cenv, crenv, _, C.ExnTag { name = _, payloadTy = _ }) = () - | goSimpleExp (env, renv, cenv, crenv, result, C.Projection { label, record, fieldTypes = _ }) = useValueAsRecord (env, label, result, record) +fun goSimpleExp (env, _, _, _, _, C.PrimOp { primOp = _, tyargs = _, args }) = List.app (useValue env) args + | goSimpleExp (env, _, _, _, _, C.Record fields) = Syntax.LabelMap.app (useValue env) fields + | goSimpleExp (_, _, _, _, _, C.ExnTag { name = _, payloadTy = _ }) = () + | goSimpleExp (env, _, _, _, result, C.Projection { label, record, fieldTypes = _ }) = useValueAsRecord (env, label, result, record) | goSimpleExp (env, renv, cenv, crenv, _, C.Abs { contParam, params, body }) = ( List.app (fn p => add (env, p)) params ; addC (cenv, contParam) @@ -811,14 +808,14 @@ and goDec (env, renv, cenv, crenv) | C.RecContDec defs => let val recursiveCEnv = List.foldl (fn ((f, _, _), m) => C.CVarMap.insert (m, f, ref neverUsedCont)) C.CVarMap.empty defs in C.CVarMap.appi (fn (f, v) => C.CVarTable.insert cenv (f, v)) recursiveCEnv - ; List.app (fn (f, params, body) => ( List.app (Option.app (fn p => add (env, p))) params + ; List.app (fn (_, params, body) => ( List.app (Option.app (fn p => add (env, p))) params ; goCExp (env, renv, cenv, crenv, body) ) ) defs ; C.CVarMap.appi (fn (f, v) => C.CVarTable.insert crenv (f, v)) recursiveCEnv ; List.app (fn (f, _, _) => C.CVarTable.insert cenv (f, ref neverUsedCont)) defs end - | C.ESImportDec { pure, specs, moduleName } => List.app (fn (_, vid) => add (env, vid)) specs + | C.ESImportDec { pure = _, specs, moduleName = _ } => List.app (fn (_, vid) => add (env, vid)) specs and goCExp (env : (usage ref) TypedSyntax.VIdTable.hash_table, renv, cenv : (cont_usage ref) C.CVarTable.hash_table, crenv, cexp) = case cexp of C.Let { decs, cont } => @@ -897,7 +894,7 @@ fun sizeOfSimpleExp (e, threshold) | C.Record fields => threshold - Syntax.LabelMap.numItems fields | C.ExnTag _ => threshold - 1 | C.Projection _ => threshold - 1 - | C.Abs { contParam, params, body } => sizeOfCExp (body, threshold) + | C.Abs { contParam = _, params = _, body } => sizeOfCExp (body, threshold) and sizeOfDec (dec, threshold) = if threshold < 0 then threshold @@ -905,7 +902,7 @@ and sizeOfDec (dec, threshold) case dec of C.ValDec { exp, result = _ } => sizeOfSimpleExp (exp, threshold) | C.RecDec defs => List.foldl (fn ((_, _, _, body), t) => sizeOfCExp (body, t)) threshold defs - | C.ContDec { name, params, body } => sizeOfCExp (body, threshold) + | C.ContDec { name = _, params = _, body } => sizeOfCExp (body, threshold) | C.RecContDec defs => List.foldl (fn ((_, _, body), t) => sizeOfCExp (body, t)) threshold defs | C.ESImportDec _ => 0 and sizeOfCExp (e, threshold) @@ -914,35 +911,35 @@ and sizeOfCExp (e, threshold) else case e of C.Let { decs, cont } => Vector.foldl sizeOfDec (sizeOfCExp (cont, threshold)) decs - | C.App { applied, cont, args } => threshold - List.length args - | C.AppCont { applied, args } => threshold - List.length args - | C.If { cond, thenCont, elseCont } => sizeOfCExp (elseCont, sizeOfCExp (thenCont, threshold - 1)) - | C.Handle { body, handler = (_, h), successfulExitIn, successfulExitOut } => sizeOfCExp (body, sizeOfCExp (h, threshold - 1)) + | C.App { applied = _, cont = _, args } => threshold - List.length args + | C.AppCont { applied = _, args } => threshold - List.length args + | C.If { cond = _, thenCont, elseCont } => sizeOfCExp (elseCont, sizeOfCExp (thenCont, threshold - 1)) + | C.Handle { body, handler = (_, h), successfulExitIn = _, successfulExitOut = _ } => sizeOfCExp (body, sizeOfCExp (h, threshold - 1)) | C.Unreachable => threshold fun substValue (subst : C.Value TypedSyntax.VIdMap.map) (x as C.Var v) = (case TypedSyntax.VIdMap.find (subst, v) of SOME w => w | NONE => x ) - | substValue subst v = v + | substValue _ v = v fun substCVar (csubst : C.CVar C.CVarMap.map) v = case C.CVarMap.find (csubst, v) of SOME w => w | NONE => v -fun substSimpleExp (subst, csubst, C.PrimOp { primOp, tyargs, args }) = C.PrimOp { primOp = primOp, tyargs = tyargs, args = List.map (substValue subst) args } - | substSimpleExp (subst, csubst, C.Record fields) = C.Record (Syntax.LabelMap.map (substValue subst) fields) - | substSimpleExp (subst, csubst, e as C.ExnTag _) = e - | substSimpleExp (subst, csubst, C.Projection { label, record, fieldTypes }) = C.Projection { label = label, record = substValue subst record, fieldTypes = fieldTypes } +fun substSimpleExp (subst, _, C.PrimOp { primOp, tyargs, args }) = C.PrimOp { primOp = primOp, tyargs = tyargs, args = List.map (substValue subst) args } + | substSimpleExp (subst, _, C.Record fields) = C.Record (Syntax.LabelMap.map (substValue subst) fields) + | substSimpleExp (_, _, e as C.ExnTag _) = e + | substSimpleExp (subst, _, C.Projection { label, record, fieldTypes }) = C.Projection { label = label, record = substValue subst record, fieldTypes = fieldTypes } | substSimpleExp (subst, csubst, C.Abs { contParam, params, body }) = C.Abs { contParam = contParam, params = params, body = substCExp (subst, csubst, body) } and substDec (subst, csubst) = fn C.ValDec { exp, result } => C.ValDec { exp = substSimpleExp (subst, csubst, exp), result = result } | C.RecDec defs => C.RecDec (List.map (fn (f, k, params, body) => (f, k, params, substCExp (subst, csubst, body))) defs) | C.ContDec { name, params, body } => C.ContDec { name = name, params = params, body = substCExp (subst, csubst, body) } | C.RecContDec defs => C.RecContDec (List.map (fn (f, params, body) => (f, params, substCExp (subst, csubst, body))) defs) - | dec as C.ESImportDec { pure, specs, moduleName } => dec + | dec as C.ESImportDec _ => dec and substCExp (subst : C.Value TypedSyntax.VIdMap.map, csubst : C.CVar C.CVarMap.map, C.Let { decs, cont }) = C.Let { decs = Vector.map (substDec (subst, csubst)) decs, cont = substCExp (subst, csubst, cont) } | substCExp (subst, csubst, C.App { applied, cont, args }) = C.App { applied = substValue subst applied, cont = substCVar csubst cont, args = List.map (substValue subst) args } | substCExp (subst, csubst, C.AppCont { applied, args }) = C.AppCont { applied = substCVar csubst applied, args = List.map (substValue subst) args } | substCExp (subst, csubst, C.If { cond, thenCont, elseCont }) = C.If { cond = substValue subst cond, thenCont = substCExp (subst, csubst, thenCont), elseCont = substCExp (subst, csubst, elseCont) } | substCExp (subst, csubst, C.Handle { body, handler = (e, h), successfulExitIn, successfulExitOut }) = C.Handle { body = substCExp (subst, csubst, body), handler = (e, substCExp (subst, csubst, h)), successfulExitIn = successfulExitIn, successfulExitOut = substCVar csubst successfulExitOut } - | substCExp (subst, csubst, e as C.Unreachable) = e + | substCExp (_, _, e as C.Unreachable) = e val substCExp = fn (subst, csubst, e) => if TypedSyntax.VIdMap.isEmpty subst andalso C.CVarMap.isEmpty csubst then e else @@ -960,7 +957,7 @@ fun alphaConvertSimpleExp (ctx, subst, csubst, C.Abs { contParam, params, body } , body = alphaConvert (ctx, subst', csubst', body) } end - | alphaConvertSimpleExp (ctx, subst, csubst, e) = substSimpleExp (subst, csubst, e) + | alphaConvertSimpleExp (_, subst, csubst, e) = substSimpleExp (subst, csubst, e) and alphaConvertDec (ctx : Context) (dec, (subst, csubst, acc)) = case dec of C.ValDec { exp, result = SOME result } => @@ -1044,12 +1041,12 @@ and alphaConvert (ctx : Context, subst : C.Value TypedSyntax.VIdMap.map, csubst = let val (subst', csubst', revDecs) = Vector.foldl (alphaConvertDec ctx) (subst, csubst, []) decs in C.Let { decs = Vector.fromList (List.rev revDecs), cont = alphaConvert (ctx, subst', csubst', cont) } end - | alphaConvert (ctx, subst, csubst, C.App { applied, cont, args }) + | alphaConvert (_, subst, csubst, C.App { applied, cont, args }) = C.App { applied = substValue subst applied , cont = substCVar csubst cont , args = List.map (substValue subst) args } - | alphaConvert (ctx, subst, csubst, C.AppCont { applied, args }) + | alphaConvert (_, subst, csubst, C.AppCont { applied, args }) = C.AppCont { applied = substCVar csubst applied, args = List.map (substValue subst) args } | alphaConvert (ctx, subst, csubst, C.If { cond, thenCont, elseCont }) = C.If { cond = substValue subst cond, thenCont = alphaConvert (ctx, subst, csubst, thenCont), elseCont = alphaConvert (ctx, subst, csubst, elseCont) } | alphaConvert (ctx, subst, csubst, C.Handle { body, handler = (e, h), successfulExitIn, successfulExitOut }) @@ -1063,7 +1060,7 @@ and alphaConvert (ctx : Context, subst : C.Value TypedSyntax.VIdMap.map, csubst , successfulExitOut = substCVar csubst successfulExitOut } end - | alphaConvert (ctx, subst, csubst, e as C.Unreachable) = e + | alphaConvert (_, _, _, e as C.Unreachable) = e datatype simplify_result = VALUE of C.Value | SIMPLE_EXP of C.SimpleExp | NOT_SIMPLIFIED @@ -1082,28 +1079,28 @@ fun isDiscardableDec (dec, env : value_info TypedSyntax.VIdMap.map) else NONE ) - | C.RecDec defs => SOME env - | C.ContDec { name, params, body } => if isDiscardableExp (env, body) then - SOME env - else - NONE + | C.RecDec _ => SOME env + | C.ContDec { name = _, params = _, body } => if isDiscardableExp (env, body) then + SOME env + else + NONE | C.RecContDec _ => NONE - | C.ESImportDec { pure, specs, moduleName } => SOME env + | C.ESImportDec { pure = _, specs = _, moduleName = _ } => SOME env and isDiscardableExp (env : value_info TypedSyntax.VIdMap.map, C.Let { decs, cont }) = (case VectorUtil.foldlOption isDiscardableDec env decs of SOME env => isDiscardableExp (env, cont) | NONE => false ) - | isDiscardableExp (env, C.App { applied = C.Var applied, cont, args }) + | isDiscardableExp (env, C.App { applied = C.Var applied, cont = _, args = _ }) = (case TypedSyntax.VIdMap.find (env, applied) of SOME { isDiscardableFunction = true, ... } => true | _ => false ) - | isDiscardableExp (env, C.App _) = false (* should not occur *) - | isDiscardableExp (env, C.AppCont _) = true - | isDiscardableExp (env, C.If { cond, thenCont, elseCont }) = isDiscardableExp (env, thenCont) andalso isDiscardableExp (env, elseCont) - | isDiscardableExp (env, C.Handle { body, handler = (e, h), successfulExitIn, successfulExitOut }) = isDiscardableExp (env, body) andalso isDiscardableExp (env, h) - | isDiscardableExp (env, C.Unreachable) = false + | isDiscardableExp (_, C.App _) = false (* should not occur *) + | isDiscardableExp (_, C.AppCont _) = true + | isDiscardableExp (env, C.If { cond = _, thenCont, elseCont }) = isDiscardableExp (env, thenCont) andalso isDiscardableExp (env, elseCont) + | isDiscardableExp (env, C.Handle { body, handler = (_, h), successfulExitIn = _, successfulExitOut = _ }) = isDiscardableExp (env, body) andalso isDiscardableExp (env, h) + | isDiscardableExp (_, C.Unreachable) = false datatype param_transform = KEEP | ELIMINATE | UNPACK of (C.Var * Syntax.Label) list fun tryUnpackParam (ctx, usage) param = case CpsUsageAnalysis.getValueUsage (usage, param) of { call = NEVER, project = NEVER, other = NEVER, ... } => ELIMINATE @@ -1133,15 +1130,15 @@ fun tryUnpackContParam (ctx, usage) (SOME param) ) [] labels) | _ => KEEP ) - | tryUnpackContParam (ctx, usage) NONE = ELIMINATE + | tryUnpackContParam (_, _) NONE = ELIMINATE fun isInt32 (x : IntInf.int) = ~0x80000000 <= x andalso x <= 0x7fffffff fun isInt54 (x : IntInf.int) = ~0x20000000000000 <= x andalso x <= 0x1fffffffffffff fun isInt64 (x : IntInf.int) = ~0x8000000000000000 <= x andalso x <= 0x7fffffffffffffff -fun isInt (P.INT, x) = false +fun isInt (P.INT, _) = false | isInt (P.I32, x) = isInt32 x | isInt (P.I54, x) = isInt54 x | isInt (P.I64, x) = isInt64 x - | isInt (P.INT_INF, x) = true + | isInt (P.INT_INF, _) = true fun wraparound (P.INT, x : IntInf.int) = x | wraparound (P.I32, x) = (x + 0x80000000) mod 0x100000000 - 0x80000000 | wraparound (P.I54, x) = (x + 0x20000000000000) mod 0x40000000000000 - 0x20000000000000 @@ -1149,8 +1146,8 @@ fun wraparound (P.INT, x : IntInf.int) = x | wraparound (P.INT_INF, x) = x fun min3 (x, y, z) = IntInf.min (x, IntInf.min (y, z)) fun max3 (x, y, z) = IntInf.max (x, IntInf.max (y, z)) -fun simplifySimpleExp (env : value_info TypedSyntax.VIdMap.map, C.Record fields) = NOT_SIMPLIFIED - | simplifySimpleExp (env, C.PrimOp { primOp, tyargs, args }) +fun simplifySimpleExp (_ : value_info TypedSyntax.VIdMap.map, C.Record _) = NOT_SIMPLIFIED + | simplifySimpleExp (env, C.PrimOp { primOp, tyargs = _, args }) = (case (primOp, args) of (F.ListOp, []) => VALUE C.Nil (* empty list *) | (F.PrimCall P.JavaScript_call, [f, C.Var args]) => @@ -1294,7 +1291,7 @@ fun simplifySimpleExp (env : value_info TypedSyntax.VIdMap.map, C.Record fields) | (F.PrimCall (P.Int_TIMES_wrapping w), [_, zero as C.IntConst (w', 0)]) => if w = w' then VALUE zero else NOT_SIMPLIFIED | (F.PrimCall (P.Int_TIMES_wrapping w), [C.IntConst (w', 1), y]) => if w = w' then VALUE y else NOT_SIMPLIFIED | (F.PrimCall (P.Int_TIMES_wrapping w), [x, C.IntConst (w', 1)]) => if w = w' then VALUE x else NOT_SIMPLIFIED - | (F.PrimCall (P.Int_TIMES_wrapping w), [x as C.IntConst (w', x'), y as C.IntConst (w'', y')]) => + | (F.PrimCall (P.Int_TIMES_wrapping w), [C.IntConst (w', x'), C.IntConst (w'', y')]) => if w = w' andalso w = w'' then VALUE (C.IntConst (w, wraparound (w, x' * y'))) else @@ -1406,8 +1403,8 @@ fun simplifySimpleExp (env : value_info TypedSyntax.VIdMap.map, C.Record fields) NOT_SIMPLIFIED | _ => NOT_SIMPLIFIED ) - | simplifySimpleExp (env, C.ExnTag _) = NOT_SIMPLIFIED - | simplifySimpleExp (env, C.Projection { label, record, fieldTypes }) + | simplifySimpleExp (_, C.ExnTag _) = NOT_SIMPLIFIED + | simplifySimpleExp (env, C.Projection { label, record, fieldTypes = _ }) = (case record of C.Var v => (case TypedSyntax.VIdMap.find (env, v) of SOME { exp = SOME (C.Record fields), ... } => (case Syntax.LabelMap.find (fields, label) of @@ -1418,7 +1415,7 @@ fun simplifySimpleExp (env : value_info TypedSyntax.VIdMap.map, C.Record fields) ) | _ => NOT_SIMPLIFIED ) - | simplifySimpleExp (env, C.Abs { contParam, params, body }) = NOT_SIMPLIFIED (* TODO: Try eta conversion *) + | simplifySimpleExp (_, C.Abs { contParam = _, params = _, body = _ }) = NOT_SIMPLIFIED (* TODO: Try eta conversion *) and simplifyDec (ctx : Context, usage : { usage : CpsUsageAnalysis.usage_table, rec_usage : CpsUsageAnalysis.usage_table, cont_usage : CpsUsageAnalysis.cont_usage_table, cont_rec_usage : CpsUsageAnalysis.cont_usage_table, dead_code_analysis : CpsDeadCodeAnalysis.usage }, appliedCont : C.CVar option) (dec, (env, cenv, subst, csubst, acc : C.Dec list)) = case dec of C.ValDec { exp, result } => @@ -1470,12 +1467,12 @@ and simplifyDec (ctx : Context, usage : { usage : CpsUsageAnalysis.usage_table, SOME paramTransforms => let val () = #simplificationOccurred ctx := true val params' = ListPair.foldrEq (fn (p, KEEP, acc) => p :: acc - | (p, ELIMINATE, acc) => acc - | (p, UNPACK fields, acc) => List.map #1 fields @ acc + | (_, ELIMINATE, acc) => acc + | (_, UNPACK fields, acc) => List.map #1 fields @ acc ) [] (params, paramTransforms) val env' = ListPair.foldlEq (fn (p, UNPACK fields, env) => TypedSyntax.VIdMap.insert (env, p, { exp = SOME (C.Record (List.foldl (fn ((fieldVar, label), map) => Syntax.LabelMap.insert (map, label, C.Var fieldVar)) Syntax.LabelMap.empty fields)), isDiscardableFunction = false }) - | (p, KEEP, env) => env - | (p, ELIMINATE, env) => env + | (_, KEEP, env) => env + | (_, ELIMINATE, env) => env ) env (params, paramTransforms) val body = simplifyCExp (ctx, env', cenv, subst, csubst, usage, body) val exp = C.Abs { contParam = contParam, params = params', body = body } @@ -1483,7 +1480,7 @@ and simplifyDec (ctx : Context, usage : { usage : CpsUsageAnalysis.usage_table, val wrapperBody = let val k = genContSym ctx val params' = List.map (fn p => renewVId (ctx, p)) params val (decs, args) = ListPair.foldrEq (fn (p, KEEP, (decs, args)) => (decs, C.Var p :: args) - | (p, ELIMINATE, acc) => acc + | (_, ELIMINATE, acc) => acc | (p, UNPACK fields, (decs, args)) => List.foldr (fn ((v, label), (decs, args)) => let val dec = C.ValDec { exp = C.Projection { label = label, record = C.Var p, fieldTypes = Syntax.LabelMap.empty (* dummy *) } @@ -1558,18 +1555,18 @@ and simplifyDec (ctx : Context, usage : { usage : CpsUsageAnalysis.usage_table, SOME paramTransforms => let val () = #simplificationOccurred ctx := true val params' = ListPair.foldrEq (fn (p, KEEP, acc) => p :: acc - | (p, ELIMINATE, acc) => acc - | (p, UNPACK fields, acc) => List.map #1 fields @ acc + | (_, ELIMINATE, acc) => acc + | (_, UNPACK fields, acc) => List.map #1 fields @ acc ) [] (params, paramTransforms) val env = ListPair.foldlEq (fn (p, UNPACK fields, env) => TypedSyntax.VIdMap.insert (env, p, { exp = SOME (C.Record (List.foldl (fn ((fieldVar, label), map) => Syntax.LabelMap.insert (map, label, C.Var fieldVar)) Syntax.LabelMap.empty fields)), isDiscardableFunction = false }) - | (p, KEEP, env) => env - | (p, ELIMINATE, env) => env + | (_, KEEP, env) => env + | (_, ELIMINATE, env) => env ) env (params, paramTransforms) val name' = renewVId (ctx, f) val wrapper = let val k = genContSym ctx val params' = List.map (fn p => renewVId (ctx, p)) params val (decs, args) = ListPair.foldrEq (fn (p, KEEP, (decs, args)) => (decs, C.Var p :: args) - | (p, ELIMINATE, acc) => acc + | (_, ELIMINATE, acc) => acc | (p, UNPACK fields, (decs, args)) => List.foldr (fn ((v, label), (decs, args)) => let val v = renewVId (ctx, v) @@ -1670,20 +1667,20 @@ and simplifyDec (ctx : Context, usage : { usage : CpsUsageAnalysis.usage_table, SOME paramTransforms => let val () = #simplificationOccurred ctx := true val params' = ListPair.foldrEq (fn (SOME p, KEEP, acc) => p :: acc - | (SOME p, ELIMINATE, acc) => acc - | (SOME p, UNPACK fields, acc) => List.map #1 fields @ acc + | (SOME _, ELIMINATE, acc) => acc + | (SOME _, UNPACK fields, acc) => List.map #1 fields @ acc | (NONE, _, acc) => acc ) [] (params, paramTransforms) val env' = ListPair.foldlEq (fn (SOME p, UNPACK fields, env) => TypedSyntax.VIdMap.insert (env, p, { exp = SOME (C.Record (List.foldl (fn ((fieldVar, label), map) => Syntax.LabelMap.insert (map, label, C.Var fieldVar)) Syntax.LabelMap.empty fields)), isDiscardableFunction = false }) - | (SOME p, KEEP, env) => env - | (SOME p, ELIMINATE, env) => env + | (SOME _, KEEP, env) => env + | (SOME _, ELIMINATE, env) => env | (NONE, _, env) => env ) env (params, paramTransforms) val body = simplifyCExp (ctx, env', cenv, subst, csubst, usage, body) val name' = renewCVar (ctx, name) val wrapperBody = let val params' = List.map (Option.map (fn p => renewVId (ctx, p))) params val (decs, args) = ListPair.foldrEq (fn (SOME p, KEEP, (decs, args)) => (decs, C.Var p :: args) - | (SOME p, ELIMINATE, acc) => acc + | (SOME _, ELIMINATE, acc) => acc | (SOME p, UNPACK fields, (decs, args)) => List.foldr (fn ((v, label), (decs, args)) => let val v = renewVId (ctx, v) @@ -1750,19 +1747,19 @@ and simplifyDec (ctx : Context, usage : { usage : CpsUsageAnalysis.usage_table, SOME paramTransforms => let val () = #simplificationOccurred ctx := true val params' = ListPair.foldrEq (fn (SOME p, KEEP, acc) => p :: acc - | (SOME p, ELIMINATE, acc) => acc - | (SOME p, UNPACK fields, acc) => List.map #1 fields @ acc + | (SOME _, ELIMINATE, acc) => acc + | (SOME _, UNPACK fields, acc) => List.map #1 fields @ acc | (NONE, _, acc) => acc ) [] (params, paramTransforms) val env' = ListPair.foldlEq (fn (SOME p, UNPACK fields, env) => TypedSyntax.VIdMap.insert (env, p, { exp = SOME (C.Record (List.foldl (fn ((fieldVar, label), map) => Syntax.LabelMap.insert (map, label, C.Var fieldVar)) Syntax.LabelMap.empty fields)), isDiscardableFunction = false }) - | (SOME p, KEEP, env) => env - | (SOME p, ELIMINATE, env) => env + | (SOME _, KEEP, env) => env + | (SOME _, ELIMINATE, env) => env | (NONE, _, env) => env ) env (params, paramTransforms) val name' = renewCVar (ctx, name) val wrapper = let val params' = List.map (Option.map (fn p => renewVId (ctx, p))) params val (decs, args) = ListPair.foldrEq (fn (SOME p, KEEP, (decs, args)) => (decs, C.Var p :: args) - | (SOME p, ELIMINATE, acc) => acc + | (SOME _, ELIMINATE, acc) => acc | (SOME p, UNPACK fields, (decs, args)) => List.foldr (fn ((v, label), (decs, args)) => let val v = renewVId (ctx, v) @@ -1804,7 +1801,7 @@ and simplifyCExp (ctx : Context, env : value_info TypedSyntax.VIdMap.map, cenv : = case e of C.Let { decs, cont } => let val appliedCont = case cont of - C.AppCont { applied, args } => SOME applied + C.AppCont { applied, args = _ } => SOME applied | _ => NONE val (env, cenv, subst, csubst, revDecs) = Vector.foldl (simplifyDec (ctx, usage, appliedCont)) (env, cenv, subst, csubst, []) decs in CpsTransform.prependRevDecs (revDecs, simplifyCExp (ctx, env, cenv, subst, csubst, usage, cont)) @@ -1832,7 +1829,7 @@ and simplifyCExp (ctx : Context, env : value_info TypedSyntax.VIdMap.map, cenv : else alphaConvert (ctx, subst, csubst, body) end - | SOME { exp, isDiscardableFunction = true } => + | SOME { exp = _, isDiscardableFunction = true } => (case C.CVarMap.find (cenv, cont) of SOME (params, _) => if not (List.exists Option.isSome params) then ( #simplificationOccurred ctx := true @@ -1890,16 +1887,16 @@ fun prependDecs ([], cont) = cont (* More sophisticated analysis is wanted. *) fun finalizeDec ctx (dec, (decs, cont)) = case dec of - C.ValDec { exp = C.PrimOp { primOp = F.PrimCall Primitives.assumeDiscardable, tyargs, args = [f, arg] }, result = SOME result } => + C.ValDec { exp = C.PrimOp { primOp = F.PrimCall Primitives.assumeDiscardable, tyargs = _, args = [f, arg] }, result = SOME result } => let val name = genContSym ctx in ([C.ContDec { name = name, params = [SOME result], body = prependDecs (decs, cont) }], C.App { applied = f, cont = name, args = [arg] }) end - | C.ValDec { exp = C.PrimOp { primOp = F.PrimCall Primitives.assumeDiscardable, tyargs, args = _ }, result = _ } => + | C.ValDec { exp = C.PrimOp { primOp = F.PrimCall Primitives.assumeDiscardable, tyargs = _, args = _ }, result = _ } => raise Fail "assumeDiscardable: invalid argument" - | C.ValDec { exp = C.PrimOp _, result } => (dec :: decs, cont) - | C.ValDec { exp = C.Record _, result } => (dec :: decs, cont) - | C.ValDec { exp = C.ExnTag _, result } => (dec :: decs, cont) - | C.ValDec { exp = C.Projection _, result } => (dec :: decs, cont) + | C.ValDec { exp = C.PrimOp _, result = _ } => (dec :: decs, cont) + | C.ValDec { exp = C.Record _, result = _ } => (dec :: decs, cont) + | C.ValDec { exp = C.ExnTag _, result = _ } => (dec :: decs, cont) + | C.ValDec { exp = C.Projection _, result = _ } => (dec :: decs, cont) | C.ValDec { exp = C.Abs { contParam, params, body }, result } => let val dec = C.ValDec { exp = C.Abs { contParam = contParam, params = params, body = finalizeCExp (ctx, body) }, result = result } in (dec :: decs, cont) @@ -1919,11 +1916,11 @@ fun finalizeDec ctx (dec, (decs, cont)) | C.ESImportDec _ => (dec :: decs, cont) and finalizeCExp (ctx, C.Let { decs, cont }) = prependDecs (Vector.foldr (finalizeDec ctx) ([], finalizeCExp (ctx, cont)) decs) - | finalizeCExp (ctx, e as C.App _) = e - | finalizeCExp (ctx, e as C.AppCont _) = e + | finalizeCExp (_, e as C.App _) = e + | finalizeCExp (_, e as C.AppCont _) = e | finalizeCExp (ctx, C.If { cond, thenCont, elseCont }) = C.If { cond = cond, thenCont = finalizeCExp (ctx, thenCont), elseCont = finalizeCExp (ctx, elseCont) } | finalizeCExp (ctx, C.Handle { body, handler = (e, h), successfulExitIn, successfulExitOut }) = C.Handle { body = finalizeCExp (ctx, body), handler = (e, finalizeCExp (ctx, h)), successfulExitIn = successfulExitIn, successfulExitOut = successfulExitOut } - | finalizeCExp (ctx, e as C.Unreachable) = e + | finalizeCExp (_, e as C.Unreachable) = e end end; @@ -1933,20 +1930,19 @@ structure CpsAnalyze :> sig val escapesTransitively : cont_map * CSyntax.CVar -> bool val contEscape : CSyntax.CVar * CSyntax.CExp -> cont_map end = struct -local structure F = FSyntax - structure C = CSyntax +local structure C = CSyntax in type cont_map = { escapes : bool, escapesTransitively : bool } CSyntax.CVarTable.hash_table fun escapes (t : cont_map, v) = #escapes (C.CVarTable.lookup t v) fun escapesTransitively (t : cont_map, v) = #escapesTransitively (C.CVarTable.lookup t v) type table = { escapes : bool ref, escapesTransitively : bool ref, level : int, free : CSyntax.CVarSet.set } CSyntax.CVarTable.hash_table -fun direct (table : table, level, k, acc) = let val { escapes, escapesTransitively, level = level', free } = C.CVarTable.lookup table k +fun direct (table : table, level, k, acc) = let val { escapes = _, escapesTransitively = _, level = level', free = _ } = C.CVarTable.lookup table k in if level' < level then C.CVarSet.add (acc, k) else acc end -fun recEscape (table : table) k = let val { escapes, escapesTransitively, level, free } = C.CVarTable.lookup table k +fun recEscape (table : table) k = let val { escapes = _, escapesTransitively, level = _, free } = C.CVarTable.lookup table k in if !escapesTransitively then () else @@ -1954,7 +1950,7 @@ fun recEscape (table : table) k = let val { escapes, escapesTransitively, level, ; C.CVarSet.app (recEscape table) free ) end -fun escape (table : table, level, k, acc) = let val { escapes, escapesTransitively, level = level', free } = C.CVarTable.lookup table k +fun escape (table : table, level, k, acc) = let val { escapes, escapesTransitively = _, level = level', free = _ } = C.CVarTable.lookup table k in escapes := true ; if level' < level then C.CVarSet.add (acc, k) @@ -1963,24 +1959,24 @@ fun escape (table : table, level, k, acc) = let val { escapes, escapesTransitive end fun goDec (table, level) (dec, acc) = case dec of - C.ValDec { exp = C.Abs { contParam, params, body }, result } => + C.ValDec { exp = C.Abs { contParam, params = _, body }, result = _ } => ( C.CVarTable.insert table (contParam, { escapes = ref false, escapesTransitively = ref false, level = 0, free = C.CVarSet.empty }) ; go (table, 0, body, acc) ) - | C.ValDec { exp, result } => acc - | C.RecDec defs => List.foldl (fn ((f, k, params, body), acc) => + | C.ValDec { exp = _, result = _ } => acc + | C.RecDec defs => List.foldl (fn ((_, k, _, body), acc) => ( C.CVarTable.insert table (k, { escapes = ref false, escapesTransitively = ref false, level = 0, free = C.CVarSet.empty }) ; go (table, 0, body, acc) ) ) acc defs - | C.ContDec { name, params, body } => + | C.ContDec { name, params = _, body } => let val free = go (table, level + 1, body, C.CVarSet.empty) in C.CVarTable.insert table (name, { escapes = ref false, escapesTransitively = ref false, level = level, free = free }) ; C.CVarSet.union (acc, free) end | C.RecContDec defs => - ( List.app (fn (name, params, body) => C.CVarTable.insert table (name, { escapes = ref false, escapesTransitively = ref false, level = level, free = C.CVarSet.empty })) defs - ; List.foldl (fn ((name, params, body), acc) => + ( List.app (fn (name, _, _) => C.CVarTable.insert table (name, { escapes = ref false, escapesTransitively = ref false, level = level, free = C.CVarSet.empty })) defs + ; List.foldl (fn ((name, _, body), acc) => let val { escapes, escapesTransitively, level, free = _ } = C.CVarTable.lookup table name val free = go (table, level + 1, body, C.CVarSet.empty) in C.CVarTable.insert table (name, { escapes = escapes, escapesTransitively = escapesTransitively, level = level, free = free }) @@ -1991,16 +1987,16 @@ fun goDec (table, level) (dec, acc) | C.ESImportDec _ => acc and go (table, level, C.Let { decs, cont }, acc) = go (table, level, cont, Vector.foldl (goDec (table, level)) acc decs) - | go (table, level, C.App { applied, cont, args }, acc) = escape (table, level, cont, acc) - | go (table, level, C.AppCont { applied, args }, acc) = direct (table, level, applied, acc) - | go (table, level, C.If { cond, thenCont, elseCont }, acc) = go (table, level, elseCont, go (table, level, thenCont, acc)) - | go (table, level, C.Handle { body, handler = (e, h), successfulExitIn, successfulExitOut }, acc) + | go (table, level, C.App { applied = _, cont, args = _ }, acc) = escape (table, level, cont, acc) + | go (table, level, C.AppCont { applied, args = _ }, acc) = direct (table, level, applied, acc) + | go (table, level, C.If { cond = _, thenCont, elseCont }, acc) = go (table, level, elseCont, go (table, level, thenCont, acc)) + | go (table, level, C.Handle { body, handler = (_, h), successfulExitIn, successfulExitOut }, acc) = let val free = go (table, level + 1, h, C.CVarSet.empty) in C.CVarTable.insert table (successfulExitIn, { escapes = ref false, escapesTransitively = ref false, level = level, free = C.CVarSet.singleton successfulExitOut }) ; C.CVarSet.app (fn k => ignore (escape (table, level + 1, k, C.CVarSet.empty))) free ; go (table, level, body, C.CVarSet.union (acc, free)) end - | go (table, level, C.Unreachable, acc) = acc + | go (_, _, C.Unreachable, acc) = acc fun contEscape (cont, cexp) = let val table = C.CVarTable.mkTable (1, C.InvalidCode "unbound continuation") in C.CVarTable.insert table (cont, { escapes = ref false, escapesTransitively = ref false, level = 0, free = C.CVarSet.empty }) ; ignore (go (table, 0, cexp, C.CVarSet.empty)) diff --git a/src/driver.sml b/src/driver.sml index f34bd5c7..9a8dcfbe 100644 --- a/src/driver.sml +++ b/src/driver.sml @@ -82,9 +82,9 @@ type Env = { fixity : Fixity.Env , toFEnv : ToFSyntax.Env } -fun compile ({ nextTyVar, nextVId, targetInfo, errorCounter } : Context, langopt : LanguageOptions.options, origEnv as { fixity, typingEnv, tynameset, toFEnv } : Env, name, source) +fun compile ({ nextTyVar, nextVId, targetInfo, errorCounter } : Context, langopt : LanguageOptions.options, { fixity, typingEnv, tynameset, toFEnv } : Env, name, source) = let val lines = Vector.fromList (String.fields (fn x => x = #"\n") source) - fun printMessage { spans, domain, message, type_ } + fun printMessage { spans, domain = _, message, type_ } = let val t = case type_ of Message.WARNING => "warning: " | Message.ERROR => "error: " diff --git a/src/fprinter.sml b/src/fprinter.sml index 9d090716..c2bf4d2d 100644 --- a/src/fprinter.sml +++ b/src/fprinter.sml @@ -9,16 +9,16 @@ structure FPrinter :> sig structure P = Printer structure F = FSyntax val showParen = P.showParen -fun doVId (Syntax.MkVId name) = [P.Fragment name] - | doVId (Syntax.GeneratedVId (name, n)) = [P.Fragment (name ^ "@" ^ Int.toString n)] -fun doStrId (Syntax.MkStrId name) = [P.Fragment name] +(* fun doVId (Syntax.MkVId name) = [P.Fragment name] + | doVId (Syntax.GeneratedVId (name, n)) = [P.Fragment (name ^ "@" ^ Int.toString n)] *) +(* fun doStrId (Syntax.MkStrId name) = [P.Fragment name] *) fun doLabel (Syntax.NumericLabel n) = [P.Fragment (Int.toString n)] | doLabel (Syntax.IdentifierLabel x) = [P.Fragment x] fun doTyVar (TypedSyntax.MkTyVar (name, n)) = [P.Fragment (name ^ "@" ^ Int.toString n)] -fun doKind prec F.TypeKind = [P.Fragment "Type"] +fun doKind _ F.TypeKind = [P.Fragment "Type"] | doKind prec (F.ArrowKind (k1, k2)) = showParen (prec >= 1) (doKind 1 k1 @ P.Fragment " -> " :: doKind 0 k2) -fun doTy prec (F.TyVar tv) = doTyVar tv - | doTy prec (F.RecordType fields) = P.Fragment "{" :: P.commaSep (Syntax.LabelMap.foldri (fn (label, ty, xs) => (doLabel label @ P.Fragment ": " :: doTy 0 ty) :: xs) [] fields) @ [P.Fragment "}"] +fun doTy _ (F.TyVar tv) = doTyVar tv + | doTy _ (F.RecordType fields) = P.Fragment "{" :: P.commaSep (Syntax.LabelMap.foldri (fn (label, ty, xs) => (doLabel label @ P.Fragment ": " :: doTy 0 ty) :: xs) [] fields) @ [P.Fragment "}"] | doTy prec (F.AppType { applied, arg }) = showParen (prec >= 2) (doTy 1 applied @ P.Fragment " " :: doTy 2 arg) | doTy prec (F.FnType (ty1, ty2)) = showParen (prec >= 1) (doTy 1 ty1 @ P.Fragment " -> " :: doTy 0 ty2) | doTy prec (F.ForallType (tv, kind, ty)) = showParen (prec >= 1) (P.Fragment "forall " :: doTyVar tv @ P.Fragment " : " :: doKind 0 kind @ P.Fragment ". " :: doTy 0 ty) @@ -31,7 +31,7 @@ fun doPrimOp (F.IntConstOp x) = [P.Fragment ("int " ^ IntInf.toString x)] | doPrimOp (F.Char16ConstOp x) = [P.Fragment ("char16 \"" ^ StringElement.charToString (StringElement.CODEUNIT x) ^ "\"")] | doPrimOp (F.String8ConstOp x) = [P.Fragment ("string8 \"" ^ String.toString x ^ "\"")] | doPrimOp (F.String16ConstOp x) = [P.Fragment ("string16 \"" ^ Vector.foldr (fn (c, acc) => StringElement.charToString (StringElement.CODEUNIT c) ^ acc) "\"" x)] - | doPrimOp (F.RaiseOp span) = [P.Fragment "raise"] + | doPrimOp (F.RaiseOp _) = [P.Fragment "raise"] | doPrimOp F.ListOp = [P.Fragment "list"] | doPrimOp F.VectorOp = [P.Fragment "vector"] | doPrimOp (F.DataTagAsStringOp _) = [P.Fragment "data-tag-as-string"] @@ -49,21 +49,21 @@ fun doPrimOp (F.IntConstOp x) = [P.Fragment ("int " ^ IntInf.toString x)] | doPrimOp F.LuaCallOp = [P.Fragment "LuaCall"] | doPrimOp F.LuaCall1Op = [P.Fragment "LuaCall1"] | doPrimOp (F.LuaMethodOp _) = [P.Fragment "LuaMethod"] -fun doPat prec (F.WildcardPat _) = [P.Fragment "_"] - | doPat prec (F.SConPat { scon = F.IntegerConstant x, ... }) = [P.Fragment (IntInf.toString x)] - | doPat prec (F.SConPat { scon = F.WordConstant x, ... }) = [P.Fragment (IntInf.toString x)] - | doPat prec (F.SConPat { scon = F.CharConstant x, ... }) = [P.Fragment (Char.toString x)] - | doPat prec (F.SConPat { scon = F.Char16Constant x, ... }) = [P.Fragment (Int.toString x)] - | doPat prec (F.SConPat { scon = F.StringConstant x, ... }) = [P.Fragment (String.toString x)] - | doPat prec (F.SConPat { scon = F.String16Constant x, ... }) = [P.Fragment ""] +fun doPat _ (F.WildcardPat _) = [P.Fragment "_"] + | doPat _ (F.SConPat { scon = F.IntegerConstant x, ... }) = [P.Fragment (IntInf.toString x)] + | doPat _ (F.SConPat { scon = F.WordConstant x, ... }) = [P.Fragment (IntInf.toString x)] + | doPat _ (F.SConPat { scon = F.CharConstant x, ... }) = [P.Fragment (Char.toString x)] + | doPat _ (F.SConPat { scon = F.Char16Constant x, ... }) = [P.Fragment (Int.toString x)] + | doPat _ (F.SConPat { scon = F.StringConstant x, ... }) = [P.Fragment (String.toString x)] + | doPat _ (F.SConPat { scon = F.String16Constant _, ... }) = [P.Fragment ""] | doPat prec (F.VarPat (_, vid, ty)) = showParen (prec >= 1) (P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : " :: doTy 0 ty) - | doPat prec (F.RecordPat { sourceSpan, fields, ellipsis, allFields }) = P.Fragment "{" :: P.commaSep (List.foldr (fn ((label, pat), xs) => (doLabel label @ P.Fragment ": " :: doPat 0 pat) :: xs) (case ellipsis of SOME basePat => [P.Fragment "...=" :: doPat 0 basePat] | NONE => []) fields) @ [P.Fragment "}"] + | doPat _ (F.RecordPat { sourceSpan = _, fields, ellipsis, allFields = _ }) = P.Fragment "{" :: P.commaSep (List.foldr (fn ((label, pat), xs) => (doLabel label @ P.Fragment ": " :: doPat 0 pat) :: xs) (case ellipsis of SOME basePat => [P.Fragment "...=" :: doPat 0 basePat] | NONE => []) fields) @ [P.Fragment "}"] | doPat prec (F.ValConPat { sourceSpan = _, info, payload = NONE }) = showParen (prec >= 1) [P.Fragment (#tag info)] - | doPat prec (F.ValConPat { sourceSpan = _, info, payload = SOME (payloadTy, payloadPat) }) = showParen (prec >= 1) (P.Fragment (#tag info) :: P.Fragment " " :: doPat 1 payloadPat) + | doPat prec (F.ValConPat { sourceSpan = _, info, payload = SOME (_, payloadPat) }) = showParen (prec >= 1) (P.Fragment (#tag info) :: P.Fragment " " :: doPat 1 payloadPat) | doPat prec (F.ExnConPat { sourceSpan = _, tagPath, payload = NONE }) = showParen (prec >= 1) (doExp 0 tagPath) - | doPat prec (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (payloadTy, payloadPat) }) = showParen (prec >= 1) (doExp 0 tagPath @ P.Fragment " " :: doPat 1 payloadPat) + | doPat prec (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (_, payloadPat) }) = showParen (prec >= 1) (doExp 0 tagPath @ P.Fragment " " :: doPat 1 payloadPat) | doPat prec (F.LayeredPat (_, vid, ty, pat)) = showParen (prec >= 1) (P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : " :: doTy 1 ty @ P.Fragment " as " :: doPat 1 pat) - | doPat prec (F.VectorPat (_, pats, wildcard, elemTy)) = P.Fragment "#[" :: P.commaSep (Vector.foldr (fn (pat, xs) => doPat 0 pat :: xs) (if wildcard then [[P.Fragment "..."]] else []) pats) @ [P.Fragment "]"] (* elemTy? *) + | doPat _ (F.VectorPat (_, pats, wildcard, _)) = P.Fragment "#[" :: P.commaSep (Vector.foldr (fn (pat, xs) => doPat 0 pat :: xs) (if wildcard then [[P.Fragment "..."]] else []) pats) @ [P.Fragment "]"] (* elemTy? *) (* precedence * atomexp ::= PrimExp | VarExp | RecordExp | ProjectionExp | StructExp | '(' exp ')' (* prec: 2 *) * appexp ::= atomexp @@ -78,23 +78,23 @@ fun doPat prec (F.WildcardPat _) = [P.Fragment "_"] | "fn type" tv ":" kind "=>" exp | "case" exp "of" matches (* prec: 0 *) *) -and doExp prec (F.PrimExp (primOp, types, exps)) = P.Fragment "_prim." :: doPrimOp primOp @ P.Fragment " [" :: P.commaSep (List.map (doTy 0) types) @ (P.Fragment "] (" :: P.commaSep (List.map (doExp 0) exps) @ [P.Fragment ")"]) - | doExp prec (F.VarExp vid) = [P.Fragment (TypedSyntax.print_VId vid)] - | doExp prec (F.RecordExp fields) = P.Fragment "{" :: P.commaSep (List.foldr (fn ((label, exp), xs) => (doLabel label @ P.Fragment " = " :: doExp 0 exp) :: xs) [] fields) @ [P.Fragment "}"] +and doExp _ (F.PrimExp (primOp, types, exps)) = P.Fragment "_prim." :: doPrimOp primOp @ P.Fragment " [" :: P.commaSep (List.map (doTy 0) types) @ (P.Fragment "] (" :: P.commaSep (List.map (doExp 0) exps) @ [P.Fragment ")"]) + | doExp _ (F.VarExp vid) = [P.Fragment (TypedSyntax.print_VId vid)] + | doExp _ (F.RecordExp fields) = P.Fragment "{" :: P.commaSep (List.foldr (fn ((label, exp), xs) => (doLabel label @ P.Fragment " = " :: doExp 0 exp) :: xs) [] fields) @ [P.Fragment "}"] | doExp prec (F.LetExp (decs, exp)) = showParen (prec >= 1) (P.Fragment "let " :: P.semicolonSep (List.map doDec decs) @ P.Fragment " in " :: doExp 0 exp @ [P.Fragment " end"]) | doExp prec (F.AppExp (applied, arg)) = showParen (prec >= 2) (doExp 1 applied @ P.Fragment " " :: doExp 2 arg) | doExp prec (F.HandleExp { body, exnName, handler }) = showParen (prec >= 1) (P.Fragment "_try " :: doExp 0 body @ P.Fragment " handle " :: P.Fragment (TypedSyntax.print_VId exnName) :: P.Fragment " => " :: doExp 0 handler) | doExp prec (F.IfThenElseExp (exp1, exp2, exp3)) = showParen (prec >= 1) (P.Fragment "if " :: doExp 0 exp1 @ P.Fragment " then " :: doExp 0 exp2 @ P.Fragment " else " :: doExp 0 exp3) - | doExp prec (F.CaseExp { sourceSpan, subjectExp, subjectTy, matches, matchType, resultTy }) = showParen (prec >= 1) (P.Fragment "case " :: doExp 0 subjectExp @ P.Fragment " : " :: doTy 0 subjectTy @ P.Fragment " of" :: P.LineTerminator :: P.IncreaseIndent 2 :: List.foldr (fn ((pat, exp), rest) => P.Indent :: P.Fragment "| " :: doPat 0 pat @ P.Fragment " => " :: doExp 0 exp @ P.LineTerminator :: rest) [P.DecreaseIndent 2, P.Indent] matches) + | doExp prec (F.CaseExp { sourceSpan = _, subjectExp, subjectTy, matches, matchType = _, resultTy = _ }) = showParen (prec >= 1) (P.Fragment "case " :: doExp 0 subjectExp @ P.Fragment " : " :: doTy 0 subjectTy @ P.Fragment " of" :: P.LineTerminator :: P.IncreaseIndent 2 :: List.foldr (fn ((pat, exp), rest) => P.Indent :: P.Fragment "| " :: doPat 0 pat @ P.Fragment " => " :: doExp 0 exp @ P.LineTerminator :: rest) [P.DecreaseIndent 2, P.Indent] matches) | doExp prec (F.FnExp (vid, ty, exp)) = showParen (prec >= 1) (P.Fragment "fn " :: P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : " :: doTy 0 ty @ P.Fragment " => " :: doExp 0 exp) - | doExp prec (F.ProjectionExp { label, record, fieldTypes }) = showParen (prec >= 2) (P.Fragment "#" :: doLabel label @ P.Fragment " " :: doExp 2 record) + | doExp prec (F.ProjectionExp { label, record, fieldTypes = _ }) = showParen (prec >= 2) (P.Fragment "#" :: doLabel label @ P.Fragment " " :: doExp 2 record) | doExp prec (F.TyAbsExp (tv, kind, exp)) = showParen (prec >= 1) (P.Fragment "fn type " :: doTyVar tv @ P.Fragment " : " :: doKind 0 kind @ P.Fragment " => " :: doExp 0 exp) | doExp prec (F.TyAppExp (exp, ty)) = showParen (prec >= 2) (doExp 1 exp @ P.Fragment " [" :: doTy 0 ty @ [P.Fragment "]"]) | doExp prec (F.PackExp { payloadTy, exp, packageTy }) = showParen (prec >= 1) (P.Fragment "_pack (type " :: doTy 0 payloadTy @ P.Fragment ", " :: doExp 0 exp @ P.Fragment ") : " :: doTy 0 packageTy) - | doExp prec (F.BogusExp _) = [P.Fragment ""] - | doExp prec F.ExitProgram = [P.Fragment ""] - | doExp prec (F.ExportValue exp) = P.Fragment "_export " :: doExp 2 exp - | doExp prec (F.ExportModule fields) = P.Fragment "_export {" :: P.commaSepV (Vector.map (fn (name, exp) => P.Fragment name :: P.Fragment " = " :: doExp 0 exp) fields) @ [P.Fragment "}"] + | doExp _ (F.BogusExp _) = [P.Fragment ""] + | doExp _ F.ExitProgram = [P.Fragment ""] + | doExp _ (F.ExportValue exp) = P.Fragment "_export " :: doExp 2 exp + | doExp _ (F.ExportModule fields) = P.Fragment "_export {" :: P.commaSepV (Vector.map (fn (name, exp) => P.Fragment name :: P.Fragment " = " :: doExp 0 exp) fields) @ [P.Fragment "}"] and doDec (F.ValDec (vid, SOME ty, exp)) = P.Fragment "val " :: P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : " :: doTy 0 ty @ P.Fragment " = " :: doExp 0 exp | doDec (F.ValDec (vid, NONE, exp)) = P.Fragment "val " :: P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : _ = " :: doExp 0 exp | doDec (F.RecValDec binds) = P.Fragment "val rec " :: P.IncreaseIndent 4 :: P.sepBy [P.LineTerminator, P.Indent, P.Fragment "and "] (List.map (fn (vid, ty, exp) => P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : " :: doTy 0 ty @ P.Fragment " = " :: doExp 0 exp) binds) @ [P.DecreaseIndent 4] @@ -103,8 +103,8 @@ and doDec (F.ValDec (vid, SOME ty, exp)) = P.Fragment "val " :: P.Fragment (Type | doDec (F.DatatypeDec datbinds) = P.Fragment "datatype " :: P.IncreaseIndent 5 :: P.sepBy [P.LineTerminator, P.Indent, P.Fragment "and "] (List.map (fn F.DatBind (tyvars, datty, conbinds) => doTyVar datty @ P.Fragment " " :: P.spaceSep (List.map doTyVar tyvars) @ P.Fragment " = " :: P.sepBy [P.Fragment " | "] (List.map (fn F.ConBind (vid, NONE) => [P.Fragment (TypedSyntax.print_VId vid)] | F.ConBind (vid, SOME ty) => P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " of " :: doTy 0 ty ) conbinds)) datbinds) @ [P.DecreaseIndent 5] - | doDec (F.ExceptionDec { name, tagName, payloadTy = NONE }) = P.Fragment "exception " :: P.Fragment (TypedSyntax.print_VId tagName) :: [] - | doDec (F.ExceptionDec { name, tagName, payloadTy = SOME payloadTy }) = P.Fragment "exception " :: P.Fragment (TypedSyntax.print_VId tagName) :: P.Fragment " of " :: doTy 0 payloadTy + | doDec (F.ExceptionDec { name = _, tagName, payloadTy = NONE }) = P.Fragment "exception " :: P.Fragment (TypedSyntax.print_VId tagName) :: [] + | doDec (F.ExceptionDec { name = _, tagName, payloadTy = SOME payloadTy }) = P.Fragment "exception " :: P.Fragment (TypedSyntax.print_VId tagName) :: P.Fragment " of " :: doTy 0 payloadTy | doDec (F.ESImportDec _) = [P.Fragment "_esImport"] -fun doDecs decs = List.concat (List.map (fn dec => P.Indent :: doDec dec @ [P.LineTerminator]) decs) +(* fun doDecs decs = List.concat (List.map (fn dec => P.Indent :: doDec dec @ [P.LineTerminator]) decs) *) end diff --git a/src/fsyntax.sml b/src/fsyntax.sml index 0f10101b..500bc4f4 100644 --- a/src/fsyntax.sml +++ b/src/fsyntax.sml @@ -208,17 +208,17 @@ fun WordConstExp (value, ty) = PrimExp (WordConstOp value, [ty], []) fun RaiseExp (span, ty, exp) = PrimExp (RaiseOp span, [ty], [exp]) fun ListExp (exps, elemTy) = PrimExp (ListOp, [elemTy], Vector.foldr (op ::) [] exps) fun VectorExp (exps, elemTy) = PrimExp (VectorOp, [elemTy], Vector.foldr (op ::) [] exps) -fun TupleType xs = let fun doFields i [] acc = acc +fun TupleType xs = let fun doFields _ [] acc = acc | doFields i (x :: xs) acc = doFields (i + 1) xs (Syntax.LabelMap.insert (acc, Syntax.NumericLabel i, x)) in RecordType (doFields 1 xs Syntax.LabelMap.empty) end fun PairType(a, b) = RecordType (Syntax.LabelMapFromList [(Syntax.NumericLabel 1, a), (Syntax.NumericLabel 2, b)]) -fun TuplePat (span, xs) = let fun doFields i nil = nil +fun TuplePat (span, xs) = let fun doFields _ nil = nil | doFields i (x :: xs) = (Syntax.NumericLabel i, x) :: doFields (i + 1) xs val allFields = #2 (List.foldl (fn (_, (i, set)) => (i + 1, Syntax.LabelSet.add (set, Syntax.NumericLabel i))) (1, Syntax.LabelSet.empty) xs) in RecordPat { sourceSpan = span, fields = doFields 1 xs, ellipsis = NONE, allFields = allFields } end -fun TupleExp xs = let fun doFields i nil = nil +fun TupleExp xs = let fun doFields _ nil = nil | doFields i (x :: xs) = (Syntax.NumericLabel i, x) :: doFields (i + 1) xs in RecordExp (doFields 1 xs) end @@ -252,18 +252,18 @@ fun occurCheck tv = | check (RecordType xs) = Syntax.LabelMap.exists check xs | check (AppType { applied, arg }) = check applied orelse check arg | check (FnType(ty1, ty2)) = check ty1 orelse check ty2 - | check (ForallType (tv', kind, ty)) = if TypedSyntax.eqUTyVar (tv, tv') then - false - else - check ty - | check (ExistsType (tv', kind, ty)) = if TypedSyntax.eqUTyVar (tv, tv') then - false - else - check ty - | check (TypeFn (tv', kind, ty)) = if TypedSyntax.eqUTyVar (tv, tv') then - false - else - check ty + | check (ForallType (tv', _, ty)) = if TypedSyntax.eqUTyVar (tv, tv') then + false + else + check ty + | check (ExistsType (tv', _, ty)) = if TypedSyntax.eqUTyVar (tv, tv') then + false + else + check ty + | check (TypeFn (tv', _, ty)) = if TypedSyntax.eqUTyVar (tv, tv') then + false + else + check ty in check end @@ -385,102 +385,102 @@ fun freeTyVarsInTy (bound : TypedSyntax.TyVarSet.set, TyVar tv) acc = if TypedSy | freeTyVarsInTy (bound, RecordType fields) acc = Syntax.LabelMap.foldl (fn (ty, acc) => freeTyVarsInTy (bound, ty) acc) acc fields | freeTyVarsInTy (bound, AppType { applied, arg }) acc = freeTyVarsInTy (bound, applied) (freeTyVarsInTy (bound, arg) acc) | freeTyVarsInTy (bound, FnType (ty1, ty2)) acc = freeTyVarsInTy (bound, ty1) (freeTyVarsInTy (bound, ty2) acc) - | freeTyVarsInTy (bound, ForallType (tv, kind, ty)) acc = freeTyVarsInTy (TypedSyntax.TyVarSet.add (bound, tv), ty) acc - | freeTyVarsInTy (bound, ExistsType (tv, kind, ty)) acc = freeTyVarsInTy (TypedSyntax.TyVarSet.add (bound, tv), ty) acc - | freeTyVarsInTy (bound, TypeFn (tv, kind, ty)) acc = freeTyVarsInTy (TypedSyntax.TyVarSet.add (bound, tv), ty) acc -fun freeTyVarsInPat (bound, WildcardPat _) acc = acc + | freeTyVarsInTy (bound, ForallType (tv, _, ty)) acc = freeTyVarsInTy (TypedSyntax.TyVarSet.add (bound, tv), ty) acc + | freeTyVarsInTy (bound, ExistsType (tv, _, ty)) acc = freeTyVarsInTy (TypedSyntax.TyVarSet.add (bound, tv), ty) acc + | freeTyVarsInTy (bound, TypeFn (tv, _, ty)) acc = freeTyVarsInTy (TypedSyntax.TyVarSet.add (bound, tv), ty) acc +fun freeTyVarsInPat (_, WildcardPat _) acc = acc | freeTyVarsInPat (bound, SConPat { sourceSpan = _, scon = _, equality, cookedValue }) acc = freeTyVarsInExp (bound, equality) (freeTyVarsInExp (bound, cookedValue) acc) - | freeTyVarsInPat (bound, VarPat (_, vid, ty)) acc = freeTyVarsInTy (bound, ty) acc - | freeTyVarsInPat (bound, RecordPat { sourceSpan, fields, ellipsis = NONE, allFields }) acc = List.foldl (fn ((label, pat), acc) => freeTyVarsInPat (bound, pat) acc) acc fields - | freeTyVarsInPat (bound, RecordPat { sourceSpan, fields, ellipsis = SOME basePat, allFields }) acc = List.foldl (fn ((label, pat), acc) => freeTyVarsInPat (bound, pat) acc) (freeTyVarsInPat (bound, basePat) acc) fields - | freeTyVarsInPat (bound, ValConPat { sourceSpan = _, info, payload = NONE }) acc = acc - | freeTyVarsInPat (bound, ValConPat { sourceSpan = _, info, payload = SOME (payloadTy, payloadPat) }) acc = freeTyVarsInTy (bound, payloadTy) (freeTyVarsInPat (bound, payloadPat) acc) + | freeTyVarsInPat (bound, VarPat (_, _, ty)) acc = freeTyVarsInTy (bound, ty) acc + | freeTyVarsInPat (bound, RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields = _ }) acc = List.foldl (fn ((_, pat), acc) => freeTyVarsInPat (bound, pat) acc) acc fields + | freeTyVarsInPat (bound, RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields = _ }) acc = List.foldl (fn ((_, pat), acc) => freeTyVarsInPat (bound, pat) acc) (freeTyVarsInPat (bound, basePat) acc) fields + | freeTyVarsInPat (_, ValConPat { sourceSpan = _, info = _, payload = NONE }) acc = acc + | freeTyVarsInPat (bound, ValConPat { sourceSpan = _, info = _, payload = SOME (payloadTy, payloadPat) }) acc = freeTyVarsInTy (bound, payloadTy) (freeTyVarsInPat (bound, payloadPat) acc) | freeTyVarsInPat (bound, ExnConPat { sourceSpan = _, tagPath, payload = NONE }) acc = freeTyVarsInExp (bound, tagPath) acc | freeTyVarsInPat (bound, ExnConPat { sourceSpan = _, tagPath, payload = SOME (payloadTy, payloadPat) }) acc = freeTyVarsInTy (bound, payloadTy) (freeTyVarsInPat (bound, payloadPat) (freeTyVarsInExp (bound, tagPath) acc)) | freeTyVarsInPat (bound, LayeredPat (_, _, ty, innerPat)) acc = freeTyVarsInTy (bound, ty) (freeTyVarsInPat (bound, innerPat) acc) - | freeTyVarsInPat (bound, VectorPat (_, pats, ellipsis, elemTy)) acc = Vector.foldr (fn (pat, acc) => freeTyVarsInPat (bound, pat) acc) (freeTyVarsInTy (bound, elemTy) acc) pats -and freeTyVarsInExp (bound : TypedSyntax.TyVarSet.set, PrimExp (primOp, tyargs, args)) acc = let val acc = List.foldl (fn (ty, acc) => freeTyVarsInTy (bound, ty) acc) acc tyargs - in List.foldl (fn (exp, acc) => freeTyVarsInExp (bound, exp) acc) acc args - end - | freeTyVarsInExp (bound, VarExp _) acc = acc - | freeTyVarsInExp (bound, RecordExp fields) acc = List.foldl (fn ((label, exp), acc) => freeTyVarsInExp (bound, exp) acc) acc fields + | freeTyVarsInPat (bound, VectorPat (_, pats, _, elemTy)) acc = Vector.foldr (fn (pat, acc) => freeTyVarsInPat (bound, pat) acc) (freeTyVarsInTy (bound, elemTy) acc) pats +and freeTyVarsInExp (bound : TypedSyntax.TyVarSet.set, PrimExp (_, tyargs, args)) acc = let val acc = List.foldl (fn (ty, acc) => freeTyVarsInTy (bound, ty) acc) acc tyargs + in List.foldl (fn (exp, acc) => freeTyVarsInExp (bound, exp) acc) acc args + end + | freeTyVarsInExp (_, VarExp _) acc = acc + | freeTyVarsInExp (bound, RecordExp fields) acc = List.foldl (fn ((_, exp), acc) => freeTyVarsInExp (bound, exp) acc) acc fields | freeTyVarsInExp (bound, LetExp (decs, exp)) acc = let val (bound, acc) = List.foldl (fn (dec, (bound, acc)) => freeTyVarsInDec (bound, dec) acc) (bound, acc) decs in freeTyVarsInExp (bound, exp) acc end | freeTyVarsInExp (bound, AppExp (exp1, exp2)) acc = freeTyVarsInExp (bound, exp1) (freeTyVarsInExp (bound, exp2) acc) - | freeTyVarsInExp (bound, HandleExp { body, exnName, handler }) acc = freeTyVarsInExp (bound, body) (freeTyVarsInExp (bound, handler) acc) + | freeTyVarsInExp (bound, HandleExp { body, exnName = _, handler }) acc = freeTyVarsInExp (bound, body) (freeTyVarsInExp (bound, handler) acc) | freeTyVarsInExp (bound, IfThenElseExp (exp1, exp2, exp3)) acc = freeTyVarsInExp (bound, exp1) (freeTyVarsInExp (bound, exp2) (freeTyVarsInExp (bound, exp3) acc)) - | freeTyVarsInExp (bound, CaseExp { sourceSpan, subjectExp, subjectTy, matches, matchType, resultTy }) acc + | freeTyVarsInExp (bound, CaseExp { sourceSpan = _, subjectExp, subjectTy, matches, matchType = _, resultTy }) acc = let val acc = freeTyVarsInExp (bound, subjectExp) acc val acc = freeTyVarsInTy (bound, subjectTy) acc val acc = freeTyVarsInTy (bound, resultTy) acc in List.foldl (fn ((pat, exp), acc) => freeTyVarsInPat (bound, pat) (freeTyVarsInExp (bound, exp) acc)) acc matches end - | freeTyVarsInExp (bound, FnExp (vid, ty, exp)) acc = freeTyVarsInTy (bound, ty) (freeTyVarsInExp (bound, exp) acc) - | freeTyVarsInExp (bound, ProjectionExp { label, record, fieldTypes }) acc = freeTyVarsInExp (bound, record) (Syntax.LabelMap.foldl (fn (ty, acc) => freeTyVarsInTy (bound, ty) acc) acc fieldTypes) - | freeTyVarsInExp (bound, TyAbsExp (tv, kind, exp)) acc = freeTyVarsInExp (TypedSyntax.TyVarSet.add (bound, tv), exp) acc + | freeTyVarsInExp (bound, FnExp (_, ty, exp)) acc = freeTyVarsInTy (bound, ty) (freeTyVarsInExp (bound, exp) acc) + | freeTyVarsInExp (bound, ProjectionExp { label = _, record, fieldTypes }) acc = freeTyVarsInExp (bound, record) (Syntax.LabelMap.foldl (fn (ty, acc) => freeTyVarsInTy (bound, ty) acc) acc fieldTypes) + | freeTyVarsInExp (bound, TyAbsExp (tv, _, exp)) acc = freeTyVarsInExp (TypedSyntax.TyVarSet.add (bound, tv), exp) acc | freeTyVarsInExp (bound, TyAppExp (exp, ty)) acc = freeTyVarsInExp (bound, exp) (freeTyVarsInTy (bound, ty) acc) | freeTyVarsInExp (bound, PackExp { payloadTy, exp, packageTy }) acc = freeTyVarsInTy (bound, payloadTy) (freeTyVarsInTy (bound, packageTy) (freeTyVarsInExp (bound, exp) acc)) | freeTyVarsInExp (bound, BogusExp ty) acc = freeTyVarsInTy (bound, ty) acc - | freeTyVarsInExp (bound, ExitProgram) acc = acc + | freeTyVarsInExp (_, ExitProgram) acc = acc | freeTyVarsInExp (bound, ExportValue x) acc = freeTyVarsInExp (bound, x) acc - | freeTyVarsInExp (bound, ExportModule entities) acc = Vector.foldl (fn ((name, exp), acc) => freeTyVarsInExp (bound, exp) acc) acc entities -and freeTyVarsInDec (bound, ValDec (vid, optTy, exp)) acc = (bound, (case optTy of - NONE => freeTyVarsInExp (bound, exp) acc - | SOME ty => freeTyVarsInTy (bound, ty) (freeTyVarsInExp (bound, exp) acc) - ) - ) - | freeTyVarsInDec (bound, RecValDec valbinds) acc = (bound, List.foldl (fn ((vid, ty, exp), acc) => freeTyVarsInTy (bound, ty) (freeTyVarsInExp (bound, exp) acc)) acc valbinds) - | freeTyVarsInDec (bound, UnpackDec (tv, kind, vid, ty, exp)) acc = let val acc = freeTyVarsInExp (bound, exp) acc - val bound = TypedSyntax.TyVarSet.add (bound, tv) - in (bound, freeTyVarsInTy (bound, ty) acc) - end + | freeTyVarsInExp (bound, ExportModule entities) acc = Vector.foldl (fn ((_, exp), acc) => freeTyVarsInExp (bound, exp) acc) acc entities +and freeTyVarsInDec (bound, ValDec (_, optTy, exp)) acc = (bound, (case optTy of + NONE => freeTyVarsInExp (bound, exp) acc + | SOME ty => freeTyVarsInTy (bound, ty) (freeTyVarsInExp (bound, exp) acc) + ) + ) + | freeTyVarsInDec (bound, RecValDec valbinds) acc = (bound, List.foldl (fn ((_, ty, exp), acc) => freeTyVarsInTy (bound, ty) (freeTyVarsInExp (bound, exp) acc)) acc valbinds) + | freeTyVarsInDec (bound, UnpackDec (tv, _, _, ty, exp)) acc = let val acc = freeTyVarsInExp (bound, exp) acc + val bound = TypedSyntax.TyVarSet.add (bound, tv) + in (bound, freeTyVarsInTy (bound, ty) acc) + end | freeTyVarsInDec (bound, IgnoreDec exp) acc = (bound, freeTyVarsInExp (bound, exp) acc) - | freeTyVarsInDec (bound, DatatypeDec datbinds) acc = let val bound = List.foldl (fn (DatBind (tyvars, tyname, conbinds), bound) => TypedSyntax.TyVarSet.add (bound, tyname)) bound datbinds - in (bound, List.foldl (fn (DatBind (tyvars, tyname, conbinds), acc) => + | freeTyVarsInDec (bound, DatatypeDec datbinds) acc = let val bound = List.foldl (fn (DatBind (_, tyname, _), bound) => TypedSyntax.TyVarSet.add (bound, tyname)) bound datbinds + in (bound, List.foldl (fn (DatBind (tyvars, _, conbinds), acc) => let val bound = TypedSyntax.TyVarSet.addList (bound, tyvars) - in List.foldl (fn (ConBind (vid, NONE), acc) => acc - | (ConBind (vid, SOME ty), acc) => freeTyVarsInTy (bound, ty) acc + in List.foldl (fn (ConBind (_, NONE), acc) => acc + | (ConBind (_, SOME ty), acc) => freeTyVarsInTy (bound, ty) acc ) acc conbinds end ) acc datbinds) end - | freeTyVarsInDec (bound, ExceptionDec { name, tagName, payloadTy }) acc = (bound, case payloadTy of - NONE => acc - | SOME payloadTy => freeTyVarsInTy (bound, payloadTy) acc - ) - | freeTyVarsInDec (bound, ESImportDec { pure, specs, moduleName }) acc = (bound, List.foldl (fn ((_, _, ty), acc) => freeTyVarsInTy (bound, ty) acc) acc specs) -and freeTyVarsInDecs (bound, decs) acc = List.foldl (fn (dec, (bound, acc)) => freeTyVarsInDec (bound, dec) acc) (bound, acc) decs + | freeTyVarsInDec (bound, ExceptionDec { name = _, tagName = _, payloadTy }) acc = (bound, case payloadTy of + NONE => acc + | SOME payloadTy => freeTyVarsInTy (bound, payloadTy) acc + ) + | freeTyVarsInDec (bound, ESImportDec { pure = _, specs, moduleName = _ }) acc = (bound, List.foldl (fn ((_, _, ty), acc) => freeTyVarsInTy (bound, ty) acc) acc specs) +(* and freeTyVarsInDecs (bound, decs) acc = List.foldl (fn (dec, (bound, acc)) => freeTyVarsInDec (bound, dec) acc) (bound, acc) decs *) fun varsInPat (WildcardPat _) acc = acc | varsInPat (SConPat _) acc = acc - | varsInPat (VarPat (_, vid, ty)) acc = TypedSyntax.VIdSet.add (acc, vid) - | varsInPat (RecordPat { sourceSpan, fields, ellipsis = NONE, allFields }) acc = List.foldl (fn ((label, pat), acc) => varsInPat pat acc) acc fields - | varsInPat (RecordPat { sourceSpan, fields, ellipsis = SOME basePat, allFields }) acc = List.foldl (fn ((label, pat), acc) => varsInPat pat acc) (varsInPat basePat acc) fields + | varsInPat (VarPat (_, vid, _)) acc = TypedSyntax.VIdSet.add (acc, vid) + | varsInPat (RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields = _ }) acc = List.foldl (fn ((_, pat), acc) => varsInPat pat acc) acc fields + | varsInPat (RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields = _ }) acc = List.foldl (fn ((_, pat), acc) => varsInPat pat acc) (varsInPat basePat acc) fields | varsInPat (ValConPat { sourceSpan = _, info = _, payload = SOME (_, payloadPat) }) acc = varsInPat payloadPat acc | varsInPat (ValConPat { sourceSpan = _, info = _, payload = NONE }) acc = acc | varsInPat (ExnConPat { sourceSpan = _, tagPath = _, payload = SOME (_, payloadPat) }) acc = varsInPat payloadPat acc | varsInPat (ExnConPat { sourceSpan = _, tagPath = _, payload = NONE }) acc = acc - | varsInPat (LayeredPat (_, vid, ty, innerPat)) acc = varsInPat innerPat (TypedSyntax.VIdSet.add (acc, vid)) - | varsInPat (VectorPat (_, pats, wildcard, ty)) acc = Vector.foldl (fn (pat, acc) => varsInPat pat acc) acc pats + | varsInPat (LayeredPat (_, vid, _, innerPat)) acc = varsInPat innerPat (TypedSyntax.VIdSet.add (acc, vid)) + | varsInPat (VectorPat (_, pats, _, _)) acc = Vector.foldl (fn (pat, acc) => varsInPat pat acc) acc pats -fun freeVarsInPat (bound : TypedSyntax.VIdSet.set, WildcardPat _) acc = acc +fun freeVarsInPat (_ : TypedSyntax.VIdSet.set, WildcardPat _) acc = acc | freeVarsInPat (bound, SConPat { sourceSpan = _, scon = _, equality, cookedValue }) acc = freeVarsInExp (bound, equality) (freeVarsInExp (bound, cookedValue) acc) - | freeVarsInPat (bound, VarPat _) acc = acc - | freeVarsInPat (bound, RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields }) acc = List.foldl (fn ((_, pat), acc) => freeVarsInPat (bound, pat) acc) acc fields - | freeVarsInPat (bound, RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields }) acc = List.foldl (fn ((_, pat), acc) => freeVarsInPat (bound, pat) acc) (freeVarsInPat (bound, basePat) acc) fields - | freeVarsInPat (bound, ValConPat { sourceSpan = _, info = _, payload = NONE }) acc = acc + | freeVarsInPat (_, VarPat _) acc = acc + | freeVarsInPat (bound, RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields = _ }) acc = List.foldl (fn ((_, pat), acc) => freeVarsInPat (bound, pat) acc) acc fields + | freeVarsInPat (bound, RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields = _ }) acc = List.foldl (fn ((_, pat), acc) => freeVarsInPat (bound, pat) acc) (freeVarsInPat (bound, basePat) acc) fields + | freeVarsInPat (_, ValConPat { sourceSpan = _, info = _, payload = NONE }) acc = acc | freeVarsInPat (bound, ValConPat { sourceSpan = _, info = _, payload = SOME (_, payloadPat) }) acc = freeVarsInPat (bound, payloadPat) acc | freeVarsInPat (bound, ExnConPat { sourceSpan = _, tagPath, payload = NONE }) acc = freeVarsInExp (bound, tagPath) acc | freeVarsInPat (bound, ExnConPat { sourceSpan = _, tagPath, payload = SOME (_, payloadPat) }) acc = freeVarsInExp (bound, tagPath) (freeVarsInPat (bound, payloadPat) acc) | freeVarsInPat (bound, LayeredPat (_, _, _, innerPat)) acc = freeVarsInPat (bound, innerPat) acc | freeVarsInPat (bound, VectorPat (_, pats, _, _)) acc = Vector.foldl (fn (pat, acc) => freeVarsInPat (bound, pat) acc) acc pats -and freeVarsInExp (bound : TypedSyntax.VIdSet.set, PrimExp (primOp, tyargs, args)) acc = List.foldl (fn (exp, acc) => freeVarsInExp (bound, exp) acc) acc args +and freeVarsInExp (bound : TypedSyntax.VIdSet.set, PrimExp (_, _, args)) acc = List.foldl (fn (exp, acc) => freeVarsInExp (bound, exp) acc) acc args | freeVarsInExp (bound, VarExp vid) acc = if TypedSyntax.VIdSet.member (bound, vid) then acc else TypedSyntax.VIdSet.add (acc, vid) - | freeVarsInExp (bound, RecordExp fields) acc = List.foldl (fn ((label, exp), acc) => freeVarsInExp (bound, exp) acc) acc fields + | freeVarsInExp (bound, RecordExp fields) acc = List.foldl (fn ((_, exp), acc) => freeVarsInExp (bound, exp) acc) acc fields | freeVarsInExp (bound, LetExp (decs, exp)) acc = let val (bound, acc) = List.foldl (fn (dec, (bound, acc)) => freeVarsInDec (bound, dec) acc) (bound, acc) decs in freeVarsInExp (bound, exp) acc end @@ -488,26 +488,26 @@ and freeVarsInExp (bound : TypedSyntax.VIdSet.set, PrimExp (primOp, tyargs, args | freeVarsInExp (bound, HandleExp { body, exnName, handler }) acc = freeVarsInExp (bound, body) (freeVarsInExp (TypedSyntax.VIdSet.add (bound, exnName), handler) acc) | freeVarsInExp (bound, IfThenElseExp (exp1, exp2, exp3)) acc = freeVarsInExp (bound, exp1) (freeVarsInExp (bound, exp2) (freeVarsInExp (bound, exp3) acc)) | freeVarsInExp (bound, CaseExp { sourceSpan = _, subjectExp, subjectTy = _, matches, matchType = _, resultTy = _ }) acc = List.foldl (fn ((pat, exp), acc) => freeVarsInExp (varsInPat pat bound, exp) (freeVarsInPat (bound, pat) acc)) (freeVarsInExp (bound, subjectExp) acc) matches - | freeVarsInExp (bound, FnExp (vid, ty, exp)) acc = freeVarsInExp (TypedSyntax.VIdSet.add (bound, vid), exp) acc - | freeVarsInExp (bound, ProjectionExp { label, record, fieldTypes }) acc = freeVarsInExp (bound, record) acc - | freeVarsInExp (bound, TyAbsExp (tv, kind, exp)) acc = freeVarsInExp (bound, exp) acc - | freeVarsInExp (bound, TyAppExp (exp, ty)) acc = freeVarsInExp (bound, exp) acc - | freeVarsInExp (bound, PackExp { payloadTy, exp, packageTy }) acc = freeVarsInExp (bound, exp) acc - | freeVarsInExp (bound, BogusExp ty) acc = acc - | freeVarsInExp (bound, ExitProgram) acc = acc + | freeVarsInExp (bound, FnExp (vid, _, exp)) acc = freeVarsInExp (TypedSyntax.VIdSet.add (bound, vid), exp) acc + | freeVarsInExp (bound, ProjectionExp { label = _, record, fieldTypes = _ }) acc = freeVarsInExp (bound, record) acc + | freeVarsInExp (bound, TyAbsExp (_, _, exp)) acc = freeVarsInExp (bound, exp) acc + | freeVarsInExp (bound, TyAppExp (exp, _)) acc = freeVarsInExp (bound, exp) acc + | freeVarsInExp (bound, PackExp { payloadTy = _, exp, packageTy = _ }) acc = freeVarsInExp (bound, exp) acc + | freeVarsInExp (_, BogusExp _) acc = acc + | freeVarsInExp (_, ExitProgram) acc = acc | freeVarsInExp (bound, ExportValue x) acc = freeVarsInExp (bound, x) acc - | freeVarsInExp (bound, ExportModule entities) acc = Vector.foldl (fn ((name, exp), acc) => freeVarsInExp (bound, exp) acc) acc entities -and freeVarsInDec (bound, ValDec (vid, ty, exp)) acc = (TypedSyntax.VIdSet.add (bound, vid), freeVarsInExp (bound, exp) acc) + | freeVarsInExp (bound, ExportModule entities) acc = Vector.foldl (fn ((_, exp), acc) => freeVarsInExp (bound, exp) acc) acc entities +and freeVarsInDec (bound, ValDec (vid, _, exp)) acc = (TypedSyntax.VIdSet.add (bound, vid), freeVarsInExp (bound, exp) acc) | freeVarsInDec (bound, RecValDec valbinds) acc = let val bound = List.foldl (fn ((vid, _, _), bound) => TypedSyntax.VIdSet.add (bound, vid)) bound valbinds in (bound, List.foldl (fn ((_, _, exp), acc) => freeVarsInExp (bound, exp) acc) acc valbinds) end - | freeVarsInDec (bound, UnpackDec (tv, kind, vid, ty, exp)) acc = (TypedSyntax.VIdSet.add (bound, vid), freeVarsInExp (bound, exp) acc) + | freeVarsInDec (bound, UnpackDec (_, _, vid, _, exp)) acc = (TypedSyntax.VIdSet.add (bound, vid), freeVarsInExp (bound, exp) acc) | freeVarsInDec (bound, IgnoreDec exp) acc = (bound, freeVarsInExp (bound, exp) acc) - | freeVarsInDec (bound, DatatypeDec datbinds) acc = (List.foldl (fn (DatBind (tyvars, tyname, conbinds), bound) => List.foldl (fn (ConBind (vid, optTy), bound) => TypedSyntax.VIdSet.add (bound, vid)) bound conbinds) bound datbinds, acc) - | freeVarsInDec (bound, ExceptionDec { name, tagName, payloadTy }) acc = (TypedSyntax.VIdSet.add (bound, tagName), acc) - | freeVarsInDec (bound, ESImportDec { pure, specs, moduleName }) acc = let val bound = List.foldl (fn ((_, vid, _), bound) => TypedSyntax.VIdSet.add (bound, vid)) bound specs - in (bound, acc) - end + | freeVarsInDec (bound, DatatypeDec datbinds) acc = (List.foldl (fn (DatBind (_, _, conbinds), bound) => List.foldl (fn (ConBind (vid, _), bound) => TypedSyntax.VIdSet.add (bound, vid)) bound conbinds) bound datbinds, acc) + | freeVarsInDec (bound, ExceptionDec { name = _, tagName, payloadTy = _ }) acc = (TypedSyntax.VIdSet.add (bound, tagName), acc) + | freeVarsInDec (bound, ESImportDec { pure = _, specs, moduleName = _ }) acc = let val bound = List.foldl (fn ((_, vid, _), bound) => TypedSyntax.VIdSet.add (bound, vid)) bound specs + in (bound, acc) + end fun getSourceSpanOfPat (WildcardPat span) = span | getSourceSpanOfPat (SConPat { sourceSpan, ... }) = sourceSpan @@ -521,7 +521,6 @@ fun getSourceSpanOfPat (WildcardPat span) = span structure PrettyPrint = struct val print_TyVar = TypedSyntax.print_TyVar val print_VId = TypedSyntax.print_VId -val print_LongVId = TypedSyntax.print_LongVId fun print_Ty (TyVar x) = "TyVar(" ^ print_TyVar x ^ ")" | print_Ty (RecordType xs) = let val xs = Syntax.LabelMap.listItemsi xs in case Syntax.extractTuple (1, xs) of @@ -530,9 +529,9 @@ fun print_Ty (TyVar x) = "TyVar(" ^ print_TyVar x ^ ")" end | print_Ty (AppType { applied, arg }) = "AppType{applied=" ^ print_Ty applied ^ ",arg=" ^ print_Ty arg ^ "}" | print_Ty (FnType(x,y)) = "FnType(" ^ print_Ty x ^ "," ^ print_Ty y ^ ")" - | print_Ty (ForallType(tv,kind,x)) = "ForallType(" ^ print_TyVar tv ^ "," ^ print_Ty x ^ ")" - | print_Ty (ExistsType(tv,kind,x)) = "ExistsType(" ^ print_TyVar tv ^ "," ^ print_Ty x ^ ")" - | print_Ty (TypeFn(tv,kind,x)) = "TypeFn(" ^ print_TyVar tv ^ "," ^ print_Ty x ^ ")" + | print_Ty (ForallType (tv, _, x)) = "ForallType(" ^ print_TyVar tv ^ "," ^ print_Ty x ^ ")" + | print_Ty (ExistsType (tv, _, x)) = "ExistsType(" ^ print_TyVar tv ^ "," ^ print_Ty x ^ ")" + | print_Ty (TypeFn (tv, _, x)) = "TypeFn(" ^ print_TyVar tv ^ "," ^ print_Ty x ^ ")" fun print_PrimOp (IntConstOp x) = "IntConstOp " ^ IntInf.toString x | print_PrimOp (WordConstOp x) = "WordConstOp " ^ IntInf.toString x | print_PrimOp (RealConstOp x) = "RealConstOp " ^ Numeric.Notation.toString "~" x @@ -540,7 +539,7 @@ fun print_PrimOp (IntConstOp x) = "IntConstOp " ^ IntInf.toString x | print_PrimOp (Char16ConstOp x) = "Char16ConstOp \"" ^ StringElement.charToString (StringElement.CODEUNIT x) ^ "\"" | print_PrimOp (String8ConstOp x) = "String8ConstOp \"" ^ String.toString x ^ "\"" | print_PrimOp (String16ConstOp x) = "String16ConstOp \"" ^ Vector.foldr (fn (c, acc) => StringElement.charToString (StringElement.CODEUNIT c) ^ acc) "\"" x - | print_PrimOp (RaiseOp span) = "RaiseOp" + | print_PrimOp (RaiseOp _) = "RaiseOp" | print_PrimOp ListOp = "ListOp" | print_PrimOp VectorOp = "VectorOp" | print_PrimOp (DataTagAsStringOp _) = "DataTagAsStringOp" @@ -559,22 +558,22 @@ fun print_PrimOp (IntConstOp x) = "IntConstOp " ^ IntInf.toString x | print_PrimOp LuaCall1Op = "LuaCall1Op" | print_PrimOp (LuaMethodOp _) = "LuaMethodOp" fun print_Pat (WildcardPat _) = "WildcardPat" - | print_Pat (SConPat { sourceSpan, scon = IntegerConstant x, equality, cookedValue }) = "SConPat(IntegerConstant " ^ IntInf.toString x ^ ")" - | print_Pat (SConPat { sourceSpan, scon = WordConstant x, equality, cookedValue }) = "SConPat(WordConstant " ^ IntInf.toString x ^ ")" - | print_Pat (SConPat { sourceSpan, scon = CharConstant x, equality, cookedValue }) = "SConPat(CharConstant #\"" ^ Char.toString x ^ "\")" - | print_Pat (SConPat { sourceSpan, scon = Char16Constant x, equality, cookedValue }) = "SConPat(Char16Constant " ^ Int.toString x ^ ")" - | print_Pat (SConPat { sourceSpan, scon = StringConstant x, equality, cookedValue }) = "SConPat(StringConstant \"" ^ String.toString x ^ "\")" - | print_Pat (SConPat { sourceSpan, scon = String16Constant x, equality, cookedValue }) = "SConPat(String16Constant)" + | print_Pat (SConPat { sourceSpan = _, scon = IntegerConstant x, equality = _, cookedValue = _ }) = "SConPat(IntegerConstant " ^ IntInf.toString x ^ ")" + | print_Pat (SConPat { sourceSpan = _, scon = WordConstant x, equality = _, cookedValue = _ }) = "SConPat(WordConstant " ^ IntInf.toString x ^ ")" + | print_Pat (SConPat { sourceSpan = _, scon = CharConstant x, equality = _, cookedValue = _ }) = "SConPat(CharConstant #\"" ^ Char.toString x ^ "\")" + | print_Pat (SConPat { sourceSpan = _, scon = Char16Constant x, equality = _, cookedValue = _ }) = "SConPat(Char16Constant " ^ Int.toString x ^ ")" + | print_Pat (SConPat { sourceSpan = _, scon = StringConstant x, equality = _, cookedValue = _ }) = "SConPat(StringConstant \"" ^ String.toString x ^ "\")" + | print_Pat (SConPat { sourceSpan = _, scon = String16Constant _, equality = _, cookedValue = _ }) = "SConPat(String16Constant)" | print_Pat (VarPat(_, vid, ty)) = "VarPat(" ^ print_VId vid ^ "," ^ print_Ty ty ^ ")" | print_Pat (LayeredPat (_, vid, ty, pat)) = "TypedPat(" ^ print_VId vid ^ "," ^ print_Ty ty ^ "," ^ print_Pat pat ^ ")" | print_Pat (ValConPat { sourceSpan = _, info, payload }) = "ValConPat(" ^ #tag info ^ "," ^ Syntax.print_option (Syntax.print_pair (print_Ty, print_Pat)) payload ^ ")" | print_Pat (ExnConPat { sourceSpan = _, tagPath, payload }) = "ExnConPat(" ^ print_Exp tagPath ^ "," ^ Syntax.print_option (Syntax.print_pair (print_Ty, print_Pat)) payload ^ ")" - | print_Pat (RecordPat { sourceSpan, fields, ellipsis = NONE, allFields }) + | print_Pat (RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields = _ }) = (case Syntax.extractTuple (1, fields) of NONE => "RecordPat(" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_Label, print_Pat)) fields ^ ",NONE)" | SOME ys => "TuplePat " ^ Syntax.print_list print_Pat ys ) - | print_Pat (RecordPat { sourceSpan, fields, ellipsis = SOME basePat, allFields }) = "RecordPat(" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_Label, print_Pat)) fields ^ ",SOME(" ^ print_Pat basePat ^ "))" + | print_Pat (RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields = _ }) = "RecordPat(" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_Label, print_Pat)) fields ^ ",SOME(" ^ print_Pat basePat ^ "))" | print_Pat (VectorPat _) = "VectorPat" and print_Exp (PrimExp (primOp, tyargs, args)) = "PrimExp(" ^ print_PrimOp primOp ^ "," ^ String.concatWith "," (List.map print_Ty tyargs) ^ "," ^ String.concatWith "," (List.map print_Exp args) ^ ")" | print_Exp (VarExp(x)) = "VarExp(" ^ print_VId x ^ ")" @@ -588,8 +587,8 @@ and print_Exp (PrimExp (primOp, tyargs, args)) = "PrimExp(" ^ print_PrimOp primO | print_Exp (IfThenElseExp(x,y,z)) = "IfThenElseExp(" ^ print_Exp x ^ "," ^ print_Exp y ^ "," ^ print_Exp z ^ ")" | print_Exp (CaseExp { subjectExp, subjectTy, matches, ... }) = "CaseExp(" ^ print_Exp subjectExp ^ "," ^ print_Ty subjectTy ^ "," ^ Syntax.print_list (Syntax.print_pair (print_Pat,print_Exp)) matches ^ ")" | print_Exp (FnExp(pname,pty,body)) = "FnExp(" ^ print_VId pname ^ "," ^ print_Ty pty ^ "," ^ print_Exp body ^ ")" - | print_Exp (ProjectionExp { label, record, fieldTypes }) = "ProjectionExp{label=" ^ Syntax.print_Label label ^ ",record=" ^ print_Exp record ^ "}" - | print_Exp (TyAbsExp(tv, kind, exp)) = "TyAbsExp(" ^ print_TyVar tv ^ "," ^ print_Exp exp ^ ")" + | print_Exp (ProjectionExp { label, record, fieldTypes = _ }) = "ProjectionExp{label=" ^ Syntax.print_Label label ^ ",record=" ^ print_Exp record ^ "}" + | print_Exp (TyAbsExp (tv, _, exp)) = "TyAbsExp(" ^ print_TyVar tv ^ "," ^ print_Exp exp ^ ")" | print_Exp (TyAppExp(exp, ty)) = "TyAppExp(" ^ print_Exp exp ^ "," ^ print_Ty ty ^ ")" | print_Exp (PackExp { payloadTy, exp, packageTy }) = "PackExp{payloadTy=" ^ print_Ty payloadTy ^ ",exp=" ^ print_Exp exp ^ ",packageTy=" ^ print_Ty packageTy ^ "}" | print_Exp (BogusExp _) = "BogusExp" @@ -601,12 +600,11 @@ and print_Dec (ValDec (vid, optTy, exp)) = (case optTy of | NONE => "ValDec(" ^ print_VId vid ^ ",NONE," ^ print_Exp exp ^ ")" ) | print_Dec (RecValDec valbinds) = "RecValDec(" ^ Syntax.print_list (fn (vid, ty, exp) => "(" ^ print_VId vid ^ "," ^ print_Ty ty ^ "," ^ print_Exp exp ^ ")") valbinds ^ ")" - | print_Dec (UnpackDec (tv, kind, vid, ty, exp)) = "UnpackDec(" ^ TypedSyntax.print_TyVar tv ^ "," ^ print_VId vid ^ "," ^ print_Ty ty ^ "," ^ print_Exp exp ^ ")" + | print_Dec (UnpackDec (tv, _, vid, ty, exp)) = "UnpackDec(" ^ TypedSyntax.print_TyVar tv ^ "," ^ print_VId vid ^ "," ^ print_Ty ty ^ "," ^ print_Exp exp ^ ")" | print_Dec (IgnoreDec exp) = "IgnoreDec(" ^ print_Exp exp ^ ")" - | print_Dec (DatatypeDec datbinds) = "DatatypeDec" + | print_Dec (DatatypeDec _) = "DatatypeDec" | print_Dec (ExceptionDec _) = "ExceptionDec" | print_Dec (ESImportDec _) = "ESImportDec" -val print_Decs = Syntax.print_list print_Dec end (* structure PrettyPrint *) end (* structure FSyntax *) @@ -679,7 +677,7 @@ fun LongStrIdExp (ctx, env : Env, spans, TypedSyntax.MkLongStrId (strid0, strids end in go (strids, FSyntax.VarExp strid0, ty0) end -fun LongVIdToExnTagExp (ctx, env : Env, spans, TypedSyntax.MkShortVId vid) = TypedSyntax.VIdMap.find (#exnTagMap env, vid) +fun LongVIdToExnTagExp (_, env : Env, _, TypedSyntax.MkShortVId vid) = TypedSyntax.VIdMap.find (#exnTagMap env, vid) | LongVIdToExnTagExp (ctx, env, spans, TypedSyntax.MkLongVId (strid0, strids, vid)) = let val strid0 = FSyntax.strIdToVId strid0 val ty0 = case TypedSyntax.VIdMap.find (#valMap env, strid0) of @@ -765,15 +763,15 @@ local structure T = TypedSyntax end in (*: val toFTy : Context * 'dummy * TypedSyntax.Ty -> FSyntax.Ty *) -fun toFTy (ctx, env : 'dummy, T.TyVar (span, tv)) = F.TyVar tv - | toFTy (ctx, env, T.AnonymousTyVar (span, ref (T.Link ty))) = toFTy (ctx, env, ty) - | toFTy (ctx, env, T.AnonymousTyVar (span, ref (T.Unbound _))) = emitFatalError (ctx, [span], "unexpected anonymous type variable") - | toFTy (ctx, env, T.RecordType (span, fields)) = F.RecordType (Syntax.LabelMap.map (fn ty => toFTy (ctx, env, ty)) fields) - | toFTy (ctx, env, T.RecordExtType (span, fields, baseTy)) = emitFatalError (ctx, [span], "unexpected record extension") - | toFTy (ctx, env, T.TyCon (span, tyargs, tyname)) = F.TyCon (List.map (fn arg => toFTy (ctx, env, arg)) tyargs, tyname) - | toFTy (ctx, env, T.FnType (span, paramTy, resultTy)) = let fun doTy ty = toFTy (ctx, env, ty) - in F.FnType (doTy paramTy, doTy resultTy) - end +fun toFTy (_, _ : 'dummy, T.TyVar (_, tv)) = F.TyVar tv + | toFTy (ctx, env, T.AnonymousTyVar (_, ref (T.Link ty))) = toFTy (ctx, env, ty) + | toFTy (ctx, _, T.AnonymousTyVar (span, ref (T.Unbound _))) = emitFatalError (ctx, [span], "unexpected anonymous type variable") + | toFTy (ctx, env, T.RecordType (_, fields)) = F.RecordType (Syntax.LabelMap.map (fn ty => toFTy (ctx, env, ty)) fields) + | toFTy (ctx, _, T.RecordExtType (span, _, _)) = emitFatalError (ctx, [span], "unexpected record extension") + | toFTy (ctx, env, T.TyCon (_, tyargs, tyname)) = F.TyCon (List.map (fn arg => toFTy (ctx, env, arg)) tyargs, tyname) + | toFTy (ctx, env, T.FnType (_, paramTy, resultTy)) = let fun doTy ty = toFTy (ctx, env, ty) + in F.FnType (doTy paramTy, doTy resultTy) + end fun cookIntegerConstant (ctx : Context, env : Env, span, value : IntInf.int, ty) = (case ty of T.TyCon (_, [], tycon) => if T.eqTyName (tycon, Typing.primTyName_int) then @@ -1036,7 +1034,7 @@ and toFExp : Context * Env * TypedSyntax.Exp -> FSyntax.Exp and toFDecs : Context * Env * TypedSyntax.Dec list -> Env * FSyntax.Dec list and getEquality : Context * Env * TypedSyntax.Ty -> FSyntax.Exp *) -fun toFPat (ctx : Context, env : Env, T.WildcardPat span) = (TypedSyntax.VIdMap.empty, F.WildcardPat span) +fun toFPat (_ : Context, _ : Env, T.WildcardPat span) = (TypedSyntax.VIdMap.empty, F.WildcardPat span) | toFPat (ctx, env, T.SConPat (span, Syntax.IntegerConstant value, ty)) = (TypedSyntax.VIdMap.empty, F.SConPat { sourceSpan = span , scon = F.IntegerConstant value @@ -1051,7 +1049,7 @@ fun toFPat (ctx : Context, env : Env, T.WildcardPat span) = (TypedSyntax.VIdMap. , cookedValue = cookWordConstant (ctx, env, span, value, ty) } ) - | toFPat (ctx, env, T.SConPat (span, Syntax.RealConstant value, ty)) = (emitError (ctx, [span], "invalid real constant in pattern"); (TypedSyntax.VIdMap.empty, F.WildcardPat span)) + | toFPat (ctx, _, T.SConPat (span, Syntax.RealConstant _, _)) = (emitError (ctx, [span], "invalid real constant in pattern"); (TypedSyntax.VIdMap.empty, F.WildcardPat span)) | toFPat (ctx, env, T.SConPat (span, Syntax.CharacterConstant value, ty)) = let val (scon, cookedValue) = cookCharacterConstant (ctx, env, span, value, ty) in (TypedSyntax.VIdMap.empty, F.SConPat { sourceSpan = span @@ -1088,14 +1086,14 @@ fun toFPat (ctx : Context, env : Env, T.WildcardPat span) = (TypedSyntax.VIdMap. | _ => emitFatalError (ctx, [sourceSpan], "invalid record pattern") in (newEnv, F.RecordPat { sourceSpan = sourceSpan, fields = fields, ellipsis = ellipsis, allFields = allFields }) end - | toFPat (ctx, env, T.ConPat { sourceSpan = span, longvid, payload, tyargs, valueConstructorInfo }) + | toFPat (ctx, env, T.ConPat { sourceSpan = span, longvid, payload, tyargs = _, valueConstructorInfo }) = let val (m, payload) = case payload of NONE => (TypedSyntax.VIdMap.empty, NONE) | SOME (payloadTy, payloadPat) => let val payloadTy = toFTy (ctx, env, payloadTy) val (m, payloadPat) = toFPat (ctx, env, payloadPat) in (m, SOME (payloadTy, payloadPat)) end - val tyargs = List.map (fn ty => toFTy (ctx, env, ty)) tyargs + (* val tyargs = List.map (fn ty => toFTy (ctx, env, ty)) tyargs *) in (m, case valueConstructorInfo of SOME info => F.ValConPat { sourceSpan = span, info = info, payload = payload } | NONE => (case LongVIdToExnTagExp (ctx, env, [span], longvid) of @@ -1144,9 +1142,9 @@ and toFExp (ctx : Context, env : Env, T.SConExp (span, Syntax.IntegerConstant va else F.TyAppExp(e, toFTy(ctx, env, ty)) ) (#1 (LongVarExp (ctx, env, [span], longvid))) tyargs - | toFExp (ctx, env, T.RecordExp (span, fields)) = let fun doField (label, e) = (label, toFExp (ctx, env, e)) - in F.RecordExp (List.map doField fields) - end + | toFExp (ctx, env, T.RecordExp (_, fields)) = let fun doField (label, e) = (label, toFExp (ctx, env, e)) + in F.RecordExp (List.map doField fields) + end | toFExp (ctx, env, T.RecordExtExp { sourceSpan, fields, baseExp, baseTy as T.RecordType (_, baseFields) }) = let fun vidForLabel (Syntax.IdentifierLabel x) = x | vidForLabel (Syntax.NumericLabel n) = "field" ^ Int.toString n @@ -1169,8 +1167,8 @@ and toFExp (ctx : Context, env : Env, T.SConExp (span, Syntax.IntegerConstant va ) [] baseFields in F.LetExp (decs @ [baseDec], F.RecordExp (fields @ baseFields)) end - | toFExp (ctx, env, T.RecordExtExp { sourceSpan, fields, baseExp, baseTy }) = emitFatalError (ctx, [sourceSpan], "record extension of non-record type: " ^ T.print_Ty baseTy) - | toFExp (ctx, env, T.LetInExp (span, decs, e)) + | toFExp (ctx, _, T.RecordExtExp { sourceSpan, fields = _, baseExp = _, baseTy }) = emitFatalError (ctx, [sourceSpan], "record extension of non-record type: " ^ T.print_Ty baseTy) + | toFExp (ctx, env, T.LetInExp (_, decs, e)) = let val (env, decs) = toFDecs(ctx, env, decs) in F.LetExp (decs, toFExp (ctx, env, e)) end @@ -1181,9 +1179,9 @@ and toFExp (ctx : Context, env : Env, T.SConExp (span, Syntax.IntegerConstant va | _ => emitFatalError (ctx, [span], "invalid record type") in F.ProjectionExp { label = label, record = toFExp (ctx, env, e2), fieldTypes = fieldTypes } end - | toFExp (ctx, env, T.AppExp (span, e1, e2)) = F.AppExp (toFExp (ctx, env, e1), toFExp (ctx, env, e2)) - | toFExp (ctx, env, T.TypedExp (span, exp, _)) = toFExp (ctx, env, exp) - | toFExp (ctx, env, T.IfThenElseExp (span, e1, e2, e3)) = F.IfThenElseExp (toFExp (ctx, env, e1), toFExp (ctx, env, e2), toFExp (ctx, env, e3)) + | toFExp (ctx, env, T.AppExp (_, e1, e2)) = F.AppExp (toFExp (ctx, env, e1), toFExp (ctx, env, e2)) + | toFExp (ctx, env, T.TypedExp (_, exp, _)) = toFExp (ctx, env, exp) + | toFExp (ctx, env, T.IfThenElseExp (_, e1, e2, e3)) = F.IfThenElseExp (toFExp (ctx, env, e1), toFExp (ctx, env, e2), toFExp (ctx, env, e3)) | toFExp (ctx, env, T.CaseExp { sourceSpan, subjectExp, subjectTy, matches, matchType, resultTy }) = let fun doMatch (pat, exp) = let val (valMap, pat') = toFPat (ctx, env, pat) val env' = updateValMap (fn m => T.VIdMap.unionWith #2 (m, valMap), env) @@ -1197,7 +1195,7 @@ and toFExp (ctx : Context, env : Env, T.SConExp (span, Syntax.IntegerConstant va , resultTy = toFTy (ctx, env, resultTy) } end - | toFExp (ctx, env, T.FnExp (span, vid, ty, body)) + | toFExp (ctx, env, T.FnExp (_, vid, ty, body)) = let val ty = toFTy(ctx, env, ty) val env' = updateValMap (fn m => T.VIdMap.insert (m, vid, ty), env) in F.FnExp (vid, ty, toFExp (ctx, env', body)) @@ -1224,8 +1222,8 @@ and toFExp (ctx : Context, env : Env, T.SConExp (span, Syntax.IntegerConstant va } end | toFExp (ctx, env, T.RaiseExp (span, ty, exp)) = F.RaiseExp (span, toFTy (ctx, env, ty), toFExp (ctx, env, exp)) - | toFExp (ctx, env, T.ListExp (span, xs, ty)) = F.ListExp (Vector.map (fn x => toFExp (ctx, env, x)) xs, toFTy (ctx, env, ty)) - | toFExp (ctx, env, T.VectorExp (span, xs, ty)) = F.VectorExp (Vector.map (fn x => toFExp (ctx, env, x)) xs, toFTy (ctx, env, ty)) + | toFExp (ctx, env, T.ListExp (_, xs, ty)) = F.ListExp (Vector.map (fn x => toFExp (ctx, env, x)) xs, toFTy (ctx, env, ty)) + | toFExp (ctx, env, T.VectorExp (_, xs, ty)) = F.VectorExp (Vector.map (fn x => toFExp (ctx, env, x)) xs, toFTy (ctx, env, ty)) | toFExp (ctx, env, T.PrimExp (span, Primitives.EQUAL, tyargs, args)) = if Vector.length tyargs = 1 andalso Vector.length args = 2 then let val tyarg = Vector.sub (tyargs, 0) val x = toFExp (ctx, env, Vector.sub (args, 0)) @@ -1234,7 +1232,7 @@ and toFExp (ctx : Context, env : Env, T.SConExp (span, Syntax.IntegerConstant va end else emitFatalError (ctx, [span], "invalid arguments to primop '=' (" ^ Int.toString (Vector.length tyargs) ^ ", " ^ Int.toString (Vector.length args) ^ ")") - | toFExp (ctx, env, T.PrimExp (span, primOp, tyargs, args)) = F.PrimExp (F.PrimCall primOp, Vector.foldr (fn (ty, xs) => toFTy (ctx, env, ty) :: xs) [] tyargs, Vector.foldr (fn (x, xs) => toFExp (ctx, env, x) :: xs) [] args) + | toFExp (ctx, env, T.PrimExp (_, primOp, tyargs, args)) = F.PrimExp (F.PrimCall primOp, Vector.foldr (fn (ty, xs) => toFTy (ctx, env, ty) :: xs) [] tyargs, Vector.foldr (fn (x, xs) => toFExp (ctx, env, x) :: xs) [] args) | toFExp (ctx, env, T.BogusExp (_, ty)) = F.BogusExp (toFTy (ctx, env, ty)) and doValBind ctx env (T.TupleBind (span, vars, exp)) = let val tupleVId = freshVId (ctx, "tmp") @@ -1244,7 +1242,7 @@ and doValBind ctx env (T.TupleBind (span, vars, exp)) val tupleFieldTypes = case tupleTy of F.RecordType fieldTypes => fieldTypes | _ => emitFatalError (ctx, [span], "invalid tuple") - val decs = let fun go (i, []) = [] + val decs = let fun go (_, []) = [] | go (i, (vid, ty) :: xs) = F.ValDec (vid, SOME ty, F.ProjectionExp { label = Syntax.NumericLabel i, record = F.VarExp tupleVId, fieldTypes = tupleFieldTypes }) :: go (i + 1, xs) in go (1, vars) end @@ -1281,7 +1279,7 @@ and typeSchemeToTy (ctx, env : 'dummy2, TypedSyntax.TypeScheme (vars, ty)) | go env ((tv, [T.IsEqType]) :: xs) = let val env' = env (* TODO *) in F.ForallType (tv, F.TypeKind, F.FnType (F.EqualityType (F.TyVar tv), go env' xs)) end - | go env ((tv, _) :: xs) = emitFatalError (ctx, [T.getSourceSpanOfTy ty], "invalid type constraint") + | go _ ((_, _) :: _) = emitFatalError (ctx, [T.getSourceSpanOfTy ty], "invalid type constraint") in go env vars end and getEquality (ctx, env, T.TyCon (span, tyargs, tyname)) @@ -1298,8 +1296,8 @@ and getEquality (ctx, env, T.TyCon (span, tyargs, tyname)) NONE => emitFatalError (ctx, [span], "equality for the type variable not found: " ^ TypedSyntax.PrettyPrint.print_TyVar tv) | SOME vid => F.VarExp vid ) - | getEquality (ctx, env, T.AnonymousTyVar (span, ref (T.Link ty))) = getEquality (ctx, env, ty) - | getEquality (ctx, env, T.AnonymousTyVar (span, ref (T.Unbound _))) = emitFatalError (ctx, [span], "unexpected anonymous type variable") + | getEquality (ctx, env, T.AnonymousTyVar (_, ref (T.Link ty))) = getEquality (ctx, env, ty) + | getEquality (ctx, _, T.AnonymousTyVar (span, ref (T.Unbound _))) = emitFatalError (ctx, [span], "unexpected anonymous type variable") | getEquality (ctx, env, recordTy as T.RecordType (span, fields)) = let val param = freshVId (ctx, "a") in if Syntax.LabelMap.isEmpty fields then @@ -1328,16 +1326,16 @@ and getEquality (ctx, env, T.TyCon (span, tyargs, tyname)) in F.FnExp (param, pairTy, body) end end - | getEquality (ctx, env, T.RecordExtType (span, fields, baseTy)) = emitFatalError (ctx, [span], "unexpected record extension") - | getEquality (ctx, env, T.FnType (span, _, _)) = emitFatalError (ctx, [span], "functions are not equatable; this should have been a type error") -and toFDecs (ctx, env, []) = (env, []) - | toFDecs (ctx, env, T.ValDec (span, valbinds) :: decs) + | getEquality (ctx, _, T.RecordExtType (span, _, _)) = emitFatalError (ctx, [span], "unexpected record extension") + | getEquality (ctx, _, T.FnType (span, _, _)) = emitFatalError (ctx, [span], "functions are not equatable; this should have been a type error") +and toFDecs (_, env, []) = (env, []) + | toFDecs (ctx, env, T.ValDec (_, valbinds) :: decs) = let val (env, dec) = List.foldl (fn (valbind, (env, decs)) => let val (env, decs') = doValBind ctx env valbind in (env, decs @ decs') end) (env, []) valbinds val (env, decs) = toFDecs (ctx, env, decs) in (env, dec @ decs) end - | toFDecs (ctx, env, T.RecValDec (span, valbinds) :: decs) - = let val valbinds' = List.map (fn T.TupleBind (span, vars, exp) => emitFatalError (ctx, [span], "unexpected TupleBind in RecValDec") + | toFDecs (ctx, env, T.RecValDec (_, valbinds) :: decs) + = let val valbinds' = List.map (fn T.TupleBind (span, _, _) => emitFatalError (ctx, [span], "unexpected TupleBind in RecValDec") | T.PolyVarBind (span, vid, T.TypeScheme (tvs, ty), exp) => let val ty0 = toFTy (ctx, env, ty) val ty' = List.foldr (fn ((tv, cts), ty1) => @@ -1351,7 +1349,7 @@ and toFDecs (ctx, env, []) = (env, []) ) valbinds val valMap = List.foldl (fn ((_, vid, ty, _, _, _), m) => T.VIdMap.insert (m, vid, ty)) (#valMap env) valbinds' val env = updateValMap (fn _ => valMap, env) - val valbinds' = List.map (fn (span, vid, ty', tvs, ty, exp) => + val valbinds' = List.map (fn (span, vid, ty', tvs, _, exp) => let fun doExp (env', []) = toFExp (ctx, env', exp) | doExp (env', (tv, cts) :: rest) = (case cts of @@ -1369,22 +1367,22 @@ and toFDecs (ctx, env, []) = (env, []) val (env, decs) = toFDecs (ctx, env, decs) in (env, F.RecValDec valbinds' :: decs) end - | toFDecs (ctx, env, T.IgnoreDec (span, exp, ty) :: decs) = let val exp = toFExp (ctx, env, exp) - val (env, decs) = toFDecs (ctx, env, decs) - in (env, F.IgnoreDec exp :: decs) - end - | toFDecs (ctx, env, T.TypeDec (span, typbinds) :: decs) = toFDecs (ctx, env, decs) - | toFDecs (ctx, env, T.DatatypeDec (span, datbinds) :: decs) - = let val dec = F.DatatypeDec (List.map (fn T.DatBind (span, tyvars, tycon, conbinds, _) => - let val conbinds = List.map (fn T.ConBind (span, vid, NONE, info) => F.ConBind (vid, NONE) - | T.ConBind (span, vid, SOME ty, info) => F.ConBind (vid, SOME (toFTy (ctx, env, ty))) + | toFDecs (ctx, env, T.IgnoreDec (_, exp, _) :: decs) = let val exp = toFExp (ctx, env, exp) + val (env, decs) = toFDecs (ctx, env, decs) + in (env, F.IgnoreDec exp :: decs) + end + | toFDecs (ctx, env, T.TypeDec (_, _) :: decs) = toFDecs (ctx, env, decs) + | toFDecs (ctx, env, T.DatatypeDec (_, datbinds) :: decs) + = let val dec = F.DatatypeDec (List.map (fn T.DatBind (_, tyvars, tycon, conbinds, _) => + let val conbinds = List.map (fn T.ConBind (_, vid, NONE, _) => F.ConBind (vid, NONE) + | T.ConBind (_, vid, SOME ty, _) => F.ConBind (vid, SOME (toFTy (ctx, env, ty))) ) conbinds in F.DatBind (tyvars, F.tyNameToTyVar tycon, conbinds) end ) datbinds) - val constructors = List.foldr (fn (T.DatBind (span, tyvars, tycon, conbinds, _), acc) => + val constructors = List.foldr (fn (T.DatBind (_, tyvars, tycon, conbinds, _), acc) => let val baseTy = F.TyCon (List.map F.TyVar tyvars, tycon) - in List.foldr (fn (T.ConBind (span, vid, optPayload, info), acc) => + in List.foldr (fn (T.ConBind (_, vid, optPayload, info), acc) => let val (ty, exp) = case optPayload of NONE => (baseTy, F.PrimExp (F.ConstructValOp info, [baseTy], [])) | SOME payloadTy => let val payloadId = freshVId (ctx, "payload") @@ -1404,9 +1402,9 @@ and toFDecs (ctx, env, []) = (env, []) val (env, decs) = toFDecs(ctx, env, decs) in (env, dec :: List.map (fn (vid, ty, exp) => F.ValDec (vid, SOME ty, exp)) constructors @ (if List.null valbinds then decs else F.RecValDec valbinds :: decs)) end - | toFDecs (ctx, env as { exnTagMap, ... }, T.ExceptionDec (span, exbinds) :: decs) + | toFDecs (ctx, env as { exnTagMap, ... }, T.ExceptionDec (_, exbinds) :: decs) = let val exnTy = FSyntax.TyCon ([], Typing.primTyName_exn) - val (env, exnTagMap, revExbinds) = List.foldl (fn (T.ExBind (span, vid as TypedSyntax.MkVId (name, _), optPayloadTy), (env, exnTagMap, revExbinds)) => + val (env, exnTagMap, revExbinds) = List.foldl (fn (T.ExBind (_, vid as TypedSyntax.MkVId (name, _), optPayloadTy), (env, exnTagMap, revExbinds)) => let val tag = freshVId (ctx, name ^ "_tag") val optPayloadTy = Option.map (fn ty => toFTy (ctx, env, ty)) optPayloadTy val (ty, exp) = case optPayloadTy of @@ -1441,31 +1439,31 @@ and toFDecs (ctx, env, []) = (env, []) val (env, decs) = toFDecs(ctx, env, decs) in (env, List.rev revExbinds @ decs) end - | toFDecs (ctx, env, T.OverloadDec (span, class, tyname, map) :: decs) = let val map = Syntax.OverloadKeyMap.map (fn exp => toFExp (ctx, env, exp)) map - val env = updateOverloadMap (fn m => TypedSyntax.TyNameMap.insert (m, tyname, map), env) - val (env, decs) = toFDecs (ctx, env, decs) - in (env, decs) - end - | toFDecs (ctx, env, T.EqualityDec (span, tyvars, tyname, exp) :: decs) = let val vid = freshVId (ctx, "eq") - val tyvarEqualities = if Typing.isRefOrArray tyname then - [] - else - List.map (fn tv => (tv, freshVId (ctx, "eq"))) tyvars - val ty = F.EqualityType (F.TyVar (F.tyNameToTyVar tyname)) - val ty = List.foldr (fn ((tv, _), ty) => F.FnType (F.EqualityType (F.TyVar tv), ty)) ty tyvarEqualities - val ty = List.foldr (fn (tv, ty) => F.ForallType (tv, F.TypeKind, ty)) ty tyvars - val env = updateEqualityForTyNameMap (fn m => TypedSyntax.TyNameMap.insert (m, tyname, TypedSyntax.MkShortVId vid), env) - val env = updateValMap (fn m => T.VIdMap.insert (m, vid, ty), env) - val innerEnv = updateEqualityForTyVarMap (fn m => List.foldl TypedSyntax.TyVarMap.insert' m tyvarEqualities, env) - val exp = toFExp (ctx, innerEnv, exp) - val exp = List.foldr (fn ((tv, eqParam), exp) => F.FnExp (eqParam, F.EqualityType (F.TyVar tv), exp)) exp tyvarEqualities - val exp = List.foldr (fn (tv, exp) => F.TyAbsExp (tv, F.TypeKind, exp)) exp tyvars - val dec = F.RecValDec [(vid, ty, exp)] - val (env, decs) = toFDecs (ctx, env, decs) - in (env, dec :: decs) - end + | toFDecs (ctx, env, T.OverloadDec (_, _, tyname, map) :: decs) = let val map = Syntax.OverloadKeyMap.map (fn exp => toFExp (ctx, env, exp)) map + val env = updateOverloadMap (fn m => TypedSyntax.TyNameMap.insert (m, tyname, map), env) + val (env, decs) = toFDecs (ctx, env, decs) + in (env, decs) + end + | toFDecs (ctx, env, T.EqualityDec (_, tyvars, tyname, exp) :: decs) = let val vid = freshVId (ctx, "eq") + val tyvarEqualities = if Typing.isRefOrArray tyname then + [] + else + List.map (fn tv => (tv, freshVId (ctx, "eq"))) tyvars + val ty = F.EqualityType (F.TyVar (F.tyNameToTyVar tyname)) + val ty = List.foldr (fn ((tv, _), ty) => F.FnType (F.EqualityType (F.TyVar tv), ty)) ty tyvarEqualities + val ty = List.foldr (fn (tv, ty) => F.ForallType (tv, F.TypeKind, ty)) ty tyvars + val env = updateEqualityForTyNameMap (fn m => TypedSyntax.TyNameMap.insert (m, tyname, TypedSyntax.MkShortVId vid), env) + val env = updateValMap (fn m => T.VIdMap.insert (m, vid, ty), env) + val innerEnv = updateEqualityForTyVarMap (fn m => List.foldl TypedSyntax.TyVarMap.insert' m tyvarEqualities, env) + val exp = toFExp (ctx, innerEnv, exp) + val exp = List.foldr (fn ((tv, eqParam), exp) => F.FnExp (eqParam, F.EqualityType (F.TyVar tv), exp)) exp tyvarEqualities + val exp = List.foldr (fn (tv, exp) => F.TyAbsExp (tv, F.TypeKind, exp)) exp tyvars + val dec = F.RecValDec [(vid, ty, exp)] + val (env, decs) = toFDecs (ctx, env, decs) + in (env, dec :: decs) + end | toFDecs (ctx, env, T.ValDescDec _ :: decs) = toFDecs (ctx, env, decs) - | toFDecs (ctx, env, T.ESImportDec { sourceSpan, pure, specs, moduleName } :: decs) + | toFDecs (ctx, env, T.ESImportDec { sourceSpan = _, pure, specs, moduleName } :: decs) = let val specs = List.map (fn (name, vid, ty) => (name, vid, toFTy (ctx, env, ty))) specs val valMap = List.foldl (fn ((_, vid, ty), valMap) => TypedSyntax.VIdMap.insert (valMap, vid, ty)) (#valMap env) specs val dec = F.ESImportDec { pure = pure, specs = specs, moduleName = moduleName } @@ -1479,10 +1477,10 @@ and toFDecs (ctx, env, []) = (env, []) in (env, dec :: decs) end and genEqualitiesForDatatypes (ctx, env, datbinds) : Env * (TypedSyntax.VId * F.Ty * F.Exp) list - = let val nameMap = List.foldl (fn (T.DatBind (span, tyvars, tycon as TypedSyntax.MkTyName (name, _), conbinds, true), map) => TypedSyntax.TyNameMap.insert (map, tycon, freshVId (ctx, "EQUAL" ^ name)) + = let val nameMap = List.foldl (fn (T.DatBind (_, _, tycon as TypedSyntax.MkTyName (name, _), _, true), map) => TypedSyntax.TyNameMap.insert (map, tycon, freshVId (ctx, "EQUAL" ^ name)) | (_, map) => map) TypedSyntax.TyNameMap.empty datbinds - val env' = updateEqualityForTyNameMap (fn m => TypedSyntax.TyNameMap.unionWith #2 (#equalityForTyNameMap env, TypedSyntax.TyNameMap.map T.MkShortVId nameMap), env) - fun updateEnv (T.DatBind (span, tyvars, tyname, conbinds, true), env) + val env' = updateEqualityForTyNameMap (fn m => TypedSyntax.TyNameMap.unionWith #2 (m, TypedSyntax.TyNameMap.map T.MkShortVId nameMap), env) + fun updateEnv (T.DatBind (_, tyvars, tyname, _, true), env) = let val vid = TypedSyntax.TyNameMap.lookup (nameMap, tyname) val tyvars'' = List.map F.TyVar tyvars val ty = List.foldr (fn (tv, ty) => F.FnType (F.EqualityType (F.TyVar tv), ty)) (F.EqualityType (F.TyCon (tyvars'', tyname))) tyvars @@ -1513,13 +1511,13 @@ and genEqualitiesForDatatypes (ctx, env, datbinds) : Env * (TypedSyntax.VId * F. , F.CaseExp { sourceSpan = span , subjectExp = F.VarExp param , subjectTy = paramTy - , matches = List.foldr (fn (T.ConBind (span, conName, NONE, info), rest) => + , matches = List.foldr (fn (T.ConBind (span, _, NONE, info), rest) => let val conPat = F.ValConPat { sourceSpan = span, info = info, payload = NONE } in ( F.TuplePat (span, [conPat, conPat]) , F.VarExp(InitialEnv.VId_true) ) :: rest end - | (T.ConBind (span, conName, SOME payloadTy, info), rest) => + | (T.ConBind (span, _, SOME payloadTy, info), rest) => let val payload1 = freshVId(ctx, "a") val payload2 = freshVId(ctx, "b") val payloadEq = getEquality(ctx, env'', payloadTy) @@ -1555,11 +1553,11 @@ and genEqualitiesForDatatypes (ctx, env, datbinds) : Env * (TypedSyntax.VId * F. val valbinds = List.foldr doDatBind [] datbinds in (env', valbinds) end -fun signatureToTy (ctx, env, { valMap, tyConMap, strMap } : T.Signature) - = let val fields = Syntax.VIdMap.foldli (fn (vid, (tysc, Syntax.ExceptionConstructor), fields) => Syntax.LabelMap.insert (fields, F.ExnTagLabel vid, toFTy (ctx, env, Typing.primTy_exntag)) - | (vid, (tysc, _), fields) => fields +fun signatureToTy (ctx, env, { valMap, tyConMap = _, strMap } : T.Signature) + = let val fields = Syntax.VIdMap.foldli (fn (vid, (_, Syntax.ExceptionConstructor), fields) => Syntax.LabelMap.insert (fields, F.ExnTagLabel vid, toFTy (ctx, env, Typing.primTy_exntag)) + | (_, (_, _), fields) => fields ) Syntax.LabelMap.empty valMap - val fields = Syntax.VIdMap.foldli (fn (vid, (tysc, ids), fields) => Syntax.LabelMap.insert (fields, F.ValueLabel vid, typeSchemeToTy (ctx, env, tysc))) fields valMap + val fields = Syntax.VIdMap.foldli (fn (vid, (tysc, _), fields) => Syntax.LabelMap.insert (fields, F.ValueLabel vid, typeSchemeToTy (ctx, env, tysc))) fields valMap val fields = Syntax.StrIdMap.foldli (fn (strid, T.MkSignature s, fields) => Syntax.LabelMap.insert (fields, F.StructLabel strid, signatureToTy (ctx, env, s))) fields strMap in F.RecordType fields end @@ -1572,7 +1570,7 @@ fun getEqualityForTypeFunction (ctx, env, T.TypeFunction (tyvars, ty)) val equality = List.foldr (fn (tv, body) => F.TyAbsExp (tv, F.TypeKind, body)) equality tyvars in equality end -fun strExpToFExp (ctx, env : Env, T.StructExp { sourceSpan, valMap, tyConMap, strMap }) : Env * F.Dec list * F.Exp * F.Ty +fun strExpToFExp (ctx, env : Env, T.StructExp { sourceSpan, valMap, tyConMap = _, strMap }) : Env * F.Dec list * F.Exp * F.Ty = let val acc = Syntax.VIdMap.foldri (fn (vid, (longvid, Syntax.ExceptionConstructor), (fieldTypes, fields)) => let val label = F.ExnTagLabel vid in ( Syntax.LabelMap.insert (fieldTypes, label, F.TyCon ([], Typing.primTyName_exntag)) @@ -1583,14 +1581,14 @@ fun strExpToFExp (ctx, env : Env, T.StructExp { sourceSpan, valMap, tyConMap, st ) :: fields ) end - | (vid, (longvid, _), acc) => acc) (Syntax.LabelMap.empty, []) valMap + | (_, (_, _), acc) => acc) (Syntax.LabelMap.empty, []) valMap val acc = Syntax.StrIdMap.foldri (fn (strid, longstrid, (fieldTypes, fields)) => let val label = F.StructLabel strid val (exp, ty) = LongStrIdExp (ctx, env, [sourceSpan], longstrid) in (Syntax.LabelMap.insert (fieldTypes, label, ty), (label, exp) :: fields) end ) acc strMap - val (fieldTypes, fields) = Syntax.VIdMap.foldri (fn (vid, (longvid, ids), (fieldTypes, fields)) => + val (fieldTypes, fields) = Syntax.VIdMap.foldri (fn (vid, (longvid, _), (fieldTypes, fields)) => let val label = F.ValueLabel vid val (exp, ty) = LongVarExp (ctx, env, [sourceSpan], longvid) in (Syntax.LabelMap.insert (fieldTypes, label, ty), (label, exp) :: fields) @@ -1601,7 +1599,7 @@ fun strExpToFExp (ctx, env : Env, T.StructExp { sourceSpan, valMap, tyConMap, st | strExpToFExp (ctx, env, T.StrIdExp (span, longstrid)) = let val (exp, ty) = LongStrIdExp (ctx, env, [span], longstrid) in (env, [], exp, ty) end - | strExpToFExp (ctx, env, T.PackedStrExp { sourceSpan, strExp, payloadTypes, packageSig }) + | strExpToFExp (ctx, env, T.PackedStrExp { sourceSpan = _, strExp, payloadTypes, packageSig }) = let val (env', decs, exp, _) = strExpToFExp (ctx, env, strExp) val packageTy = signatureToTy (ctx, env, #s packageSig) fun EqualityTyForArity 0 xs t = List.foldl F.FnType (F.EqualityType t) xs @@ -1624,7 +1622,7 @@ fun strExpToFExp (ctx, env : Env, T.StructExp { sourceSpan, valMap, tyConMap, st ) (exp, packageTy) (payloadTypes, #bound packageSig) in (env', decs, exp, packageTy) end - | strExpToFExp (ctx, env, T.FunctorAppExp { sourceSpan, funId, argumentTypes, argumentStr, packageSig }) + | strExpToFExp (ctx, env, T.FunctorAppExp { sourceSpan, funId, argumentTypes, argumentStr, packageSig = _ }) = let val (env', decs, argumentStr, _) = strExpToFExp (ctx, env, argumentStr) (* val packageTy = signatureToTy (ctx, env, #s packageSig) *) (* ... ... *) @@ -1644,8 +1642,8 @@ fun strExpToFExp (ctx, env : Env, T.StructExp { sourceSpan, valMap, tyConMap, st val exp = List.foldl (fn ({ typeFunction, admitsEquality = true }, exp) => F.AppExp (exp, getEqualityForTypeFunction (ctx, env, typeFunction)) | ({ typeFunction = _, admitsEquality = false }, exp) => exp ) exp argumentTypes (* apply the equalities *) - val ty = List.foldl (fn ({ typeFunction, admitsEquality = true }, F.FnType (_, ty)) => ty - | ({ typeFunction, admitsEquality = true }, _) => emitFatalError (ctx, [sourceSpan], "invalid functor type") + val ty = List.foldl (fn ({ typeFunction = _, admitsEquality = true }, F.FnType (_, ty)) => ty + | ({ typeFunction = _, admitsEquality = true }, _) => emitFatalError (ctx, [sourceSpan], "invalid functor type") | ({ typeFunction = _, admitsEquality = false }, ty) => ty ) ty argumentTypes (* apply the equalities *) val exp = F.AppExp (exp, argumentStr) (* apply the structure *) @@ -1654,55 +1652,55 @@ fun strExpToFExp (ctx, env : Env, T.StructExp { sourceSpan, valMap, tyConMap, st | _ => emitFatalError (ctx, [sourceSpan], "invalid functor type") in (env (* What to do? *), decs, exp, ty) end - | strExpToFExp (ctx, env, T.LetInStrExp (span, strdecs, strexp)) = let val (env', decs) = strDecsToFDecs (ctx, env, strdecs) - val (env', decs', exp, ty) = strExpToFExp (ctx, env', strexp) - in (env', decs @ decs', exp, ty) - end -and strDecToFDecs (ctx, env : Env, T.CoreDec (span, dec)) = toFDecs (ctx, env, [dec]) + | strExpToFExp (ctx, env, T.LetInStrExp (_, strdecs, strexp)) = let val (env', decs) = strDecsToFDecs (ctx, env, strdecs) + val (env', decs', exp, ty) = strExpToFExp (ctx, env', strexp) + in (env', decs @ decs', exp, ty) + end +and strDecToFDecs (ctx, env : Env, T.CoreDec (_, dec)) = toFDecs (ctx, env, [dec]) | strDecToFDecs (ctx, env, T.StrBindDec (span, strid, strexp, { s, bound })) = let val vid = F.strIdToVId strid val ty = signatureToTy (ctx, env, s) val (env', decs0, exp, packageTy) = strExpToFExp (ctx, env, strexp) val env'' = updateEqualityForTyNameMap (fn m => TypedSyntax.TyNameMap.unionWith #2 (m, #equalityForTyNameMap env'), env) val env'' = updateValMap (fn m => T.VIdMap.insert (m, vid, ty), env'') - val (revDecs, exp, ty', env) = List.foldl (fn ({ tyname, arity, admitsEquality }, (revDecs, exp, packageTy, env)) => - case packageTy of - F.ExistsType (tv, _, payloadTy) => - if admitsEquality then - case payloadTy of - F.RecordType fieldTypes => - let val packageVId = freshVId (ctx, case vid of T.MkVId (name, _) => name) - val equalityVId = freshVId (ctx, "eq") - val equalityTy = case Syntax.LabelMap.find (fieldTypes, Syntax.NumericLabel 1) of - SOME ty => ty - | NONE => emitFatalError (ctx, [span], "invalid record") - val strVId = freshVId (ctx, case vid of T.MkVId (name,_) => name) - val strTy = case Syntax.LabelMap.find (fieldTypes, Syntax.NumericLabel 2) of - SOME ty => ty - | NONE => emitFatalError (ctx, [span], "invalid record") - val env = updateEqualityForTyNameMap (fn m => T.TyNameMap.insert (m, tyname, T.MkShortVId equalityVId), env) - val env = updateValMap (fn m => T.VIdMap.insert (T.VIdMap.insert (T.VIdMap.insert (m, packageVId, payloadTy), equalityVId, equalityTy), strVId, strTy), env) - in ( F.ValDec (equalityVId, SOME equalityTy, F.ProjectionExp { label = Syntax.NumericLabel 1, record = F.VarExp packageVId, fieldTypes = fieldTypes }) - :: F.ValDec (strVId, SOME strTy, F.ProjectionExp { label = Syntax.NumericLabel 2, record = F.VarExp packageVId, fieldTypes = fieldTypes }) - :: F.UnpackDec (F.tyNameToTyVar tyname, F.arityToKind arity, packageVId, payloadTy, exp) - :: revDecs - , F.VarExp strVId - , strTy - , env - ) - end - | _ => emitFatalError (ctx, [span], "expected RecordType") - else - let val vid = freshVId (ctx, case vid of T.MkVId (name, _) => name) - val env = updateValMap (fn m => T.VIdMap.insert (m, vid, payloadTy), env) - in (F.UnpackDec (F.tyNameToTyVar tyname, F.arityToKind arity, vid, payloadTy, exp) :: revDecs, F.VarExp vid, payloadTy, env) - end - | _ => emitFatalError (ctx, [span], "expected ExistsType, but got " ^ F.PrettyPrint.print_Ty packageTy) - ) ([], exp, packageTy, env'') bound + val (revDecs, exp, _ (* ty' *), env) = List.foldl (fn ({ tyname, arity, admitsEquality }, (revDecs, exp, packageTy, env)) => + case packageTy of + F.ExistsType (_, _, payloadTy) => + if admitsEquality then + case payloadTy of + F.RecordType fieldTypes => + let val packageVId = freshVId (ctx, case vid of T.MkVId (name, _) => name) + val equalityVId = freshVId (ctx, "eq") + val equalityTy = case Syntax.LabelMap.find (fieldTypes, Syntax.NumericLabel 1) of + SOME ty => ty + | NONE => emitFatalError (ctx, [span], "invalid record") + val strVId = freshVId (ctx, case vid of T.MkVId (name,_) => name) + val strTy = case Syntax.LabelMap.find (fieldTypes, Syntax.NumericLabel 2) of + SOME ty => ty + | NONE => emitFatalError (ctx, [span], "invalid record") + val env = updateEqualityForTyNameMap (fn m => T.TyNameMap.insert (m, tyname, T.MkShortVId equalityVId), env) + val env = updateValMap (fn m => T.VIdMap.insert (T.VIdMap.insert (T.VIdMap.insert (m, packageVId, payloadTy), equalityVId, equalityTy), strVId, strTy), env) + in ( F.ValDec (equalityVId, SOME equalityTy, F.ProjectionExp { label = Syntax.NumericLabel 1, record = F.VarExp packageVId, fieldTypes = fieldTypes }) + :: F.ValDec (strVId, SOME strTy, F.ProjectionExp { label = Syntax.NumericLabel 2, record = F.VarExp packageVId, fieldTypes = fieldTypes }) + :: F.UnpackDec (F.tyNameToTyVar tyname, F.arityToKind arity, packageVId, payloadTy, exp) + :: revDecs + , F.VarExp strVId + , strTy + , env + ) + end + | _ => emitFatalError (ctx, [span], "expected RecordType") + else + let val vid = freshVId (ctx, case vid of T.MkVId (name, _) => name) + val env = updateValMap (fn m => T.VIdMap.insert (m, vid, payloadTy), env) + in (F.UnpackDec (F.tyNameToTyVar tyname, F.arityToKind arity, vid, payloadTy, exp) :: revDecs, F.VarExp vid, payloadTy, env) + end + | _ => emitFatalError (ctx, [span], "expected ExistsType, but got " ^ F.PrettyPrint.print_Ty packageTy) + ) ([], exp, packageTy, env'') bound (* ty and ty' should be the same *) in (env, decs0 @ List.rev (F.ValDec (vid, SOME ty, exp) :: revDecs)) end -and strDecsToFDecs(ctx, env : Env, []) = (env, []) +and strDecsToFDecs (_, env : Env, []) = (env, []) | strDecsToFDecs(ctx, env, dec :: decs) = let val (env, dec) = strDecToFDecs(ctx, env, dec) val (env, decs) = strDecsToFDecs(ctx, env, decs) in (env, dec @ decs) @@ -1728,14 +1726,14 @@ fun funDecToFDec(ctx, env, (funid, (types, paramStrId, paramSig, bodyStr))) : En val (_, bodyDecs, bodyExp, bodyTy) = strExpToFExp (ctx, env', bodyStr) val funexp = F.FnExp (paramId, paramSigTy, F.LetExp (bodyDecs, bodyExp)) val funTy = F.FnType (paramSigTy, bodyTy) - val funexp = List.foldr (fn ((tyname, arity, vid), funexp) => F.FnExp (vid, F.EqualityType (F.TyVar (F.tyNameToTyVar tyname)), funexp)) funexp equalityVars (* equalities *) - val funTy = List.foldr (fn ((tyname, arity, _), funTy) => F.FnType (F.EqualityType (F.TyVar (F.tyNameToTyVar tyname)), funTy)) funTy equalityVars (* equalities *) + val funexp = List.foldr (fn ((tyname, _, vid), funexp) => F.FnExp (vid, F.EqualityType (F.TyVar (F.tyNameToTyVar tyname)), funexp)) funexp equalityVars (* equalities *) + val funTy = List.foldr (fn ((tyname, _, _), funTy) => F.FnType (F.EqualityType (F.TyVar (F.tyNameToTyVar tyname)), funTy)) funTy equalityVars (* equalities *) val funexp = List.foldr (fn ({ tyname, arity, admitsEquality = _ }, funexp) => F.TyAbsExp (F.tyNameToTyVar tyname, F.arityToKind arity, funexp)) funexp types (* type parameters *) val funTy = List.foldr (fn ({ tyname, arity, admitsEquality = _ }, funTy) => F.ForallType (F.tyNameToTyVar tyname, F.arityToKind arity, funTy)) funTy types (* type parameters *) val env = updateValMap (fn m => T.VIdMap.insert (m, funid, funTy), env) in (env, F.ValDec (funid, SOME funTy, funexp)) end -fun programToFDecs(ctx, env : Env, []) = (env, []) +fun programToFDecs (_, env : Env, []) = (env, []) | programToFDecs (ctx, env, TypedSyntax.StrDec dec :: topdecs) = let val (env, decs) = strDecToFDecs (ctx, env, dec) val (env, decs') = programToFDecs (ctx, env, topdecs) in (env, decs @ decs') @@ -1787,23 +1785,23 @@ val initialEnv : Env = { equalityForTyVarMap = TypedSyntax.TyVarMap.empty , overloadMap = TypedSyntax.TyNameMap.empty , valMap = let open InitialEnv val initialValMap = #valMap initialEnv - fun toFTy (T.TyVar (span, tv)) = F.TyVar tv - | toFTy (T.AnonymousTyVar (span, ref (T.Link ty))) = toFTy ty - | toFTy (T.AnonymousTyVar (span, ref (T.Unbound _))) = raise Fail "unexpected anonymous type variable" - | toFTy (T.RecordType (span, fields)) = F.RecordType (Syntax.LabelMap.map toFTy fields) - | toFTy (T.RecordExtType (span, fields, baseTy)) = raise Fail "unexpected record extension" - | toFTy (T.TyCon (span, tyargs, tyname)) = F.TyCon (List.map toFTy tyargs, tyname) - | toFTy (T.FnType (span, paramTy, resultTy)) = F.FnType (toFTy paramTy, toFTy resultTy) + fun toFTy (T.TyVar (_, tv)) = F.TyVar tv + | toFTy (T.AnonymousTyVar (_, ref (T.Link ty))) = toFTy ty + | toFTy (T.AnonymousTyVar (_, ref (T.Unbound _))) = raise Fail "unexpected anonymous type variable" + | toFTy (T.RecordType (_, fields)) = F.RecordType (Syntax.LabelMap.map toFTy fields) + | toFTy (T.RecordExtType (_, _, _)) = raise Fail "unexpected record extension" + | toFTy (T.TyCon (_, tyargs, tyname)) = F.TyCon (List.map toFTy tyargs, tyname) + | toFTy (T.FnType (_, paramTy, resultTy)) = F.FnType (toFTy paramTy, toFTy resultTy) fun typeSchemeToTy (TypedSyntax.TypeScheme (vars, ty)) = let fun go [] = toFTy ty | go ((tv, []) :: xs) = F.ForallType (tv, F.TypeKind, go xs) | go ((tv, [T.IsEqType]) :: xs) = F.ForallType (tv, F.TypeKind, F.FnType (F.EqualityType (F.TyVar tv), go xs)) - | go ((tv, _) :: xs) = raise Fail "invalid type scheme" + | go ((_, _) :: _) = raise Fail "invalid type scheme" in go vars end - val initialValMap = Syntax.VIdMap.foldl (fn ((tysc, ids, vid), m) => case vid of - TypedSyntax.MkShortVId vid => TypedSyntax.VIdMap.insert (m, vid, typeSchemeToTy tysc) - | TypedSyntax.MkLongVId _ => raise Fail "unexpected longvid") TypedSyntax.VIdMap.empty initialValMap + val initialValMap = Syntax.VIdMap.foldl (fn ((tysc, _, vid), m) => case vid of + TypedSyntax.MkShortVId vid => TypedSyntax.VIdMap.insert (m, vid, typeSchemeToTy tysc) + | TypedSyntax.MkLongVId _ => raise Fail "unexpected longvid") TypedSyntax.VIdMap.empty initialValMap in List.foldl TypedSyntax.VIdMap.insert' initialValMap [(VId_Match_tag, FSyntax.TyCon ([], Typing.primTyName_exntag)) ,(VId_Bind_tag, FSyntax.TyCon ([], Typing.primTyName_exntag)) diff --git a/src/ftransform.sml b/src/ftransform.sml index f4d511b0..ce0d3211 100644 --- a/src/ftransform.sml +++ b/src/ftransform.sml @@ -27,8 +27,8 @@ fun freshVId(ctx : Context, name: string) = let val n = !(#nextVId ctx) fun isWildcardPat (F.WildcardPat _) = true | isWildcardPat (F.SConPat _) = false | isWildcardPat (F.VarPat _) = false - | isWildcardPat (F.RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields }) = List.all (fn (label, pat) => isWildcardPat pat) fields - | isWildcardPat (F.RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields }) = isWildcardPat basePat andalso List.all (fn (label, pat) => isWildcardPat pat) fields + | isWildcardPat (F.RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields = _ }) = List.all (fn (_, pat) => isWildcardPat pat) fields + | isWildcardPat (F.RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields = _ }) = isWildcardPat basePat andalso List.all (fn (_, pat) => isWildcardPat pat) fields | isWildcardPat (F.ValConPat _) = false (* TODO *) | isWildcardPat (F.ExnConPat _) = false | isWildcardPat (F.LayeredPat _) = false @@ -37,7 +37,7 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D = let fun doExp exp0 = (case exp0 of F.PrimExp (primOp, tyargs, args) => F.PrimExp (primOp, tyargs, List.map doExp args) - | F.VarExp longvid => exp0 + | F.VarExp _ => exp0 | F.RecordExp fields => F.RecordExp (List.map (fn (label, e) => (label, doExp e)) fields) | F.LetExp (decs, exp) => F.LetExp (List.map doDec decs, doExp exp) | F.AppExp (exp1, exp2) => F.AppExp (doExp exp1, doExp exp2) @@ -48,7 +48,7 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D | F.TyAbsExp (tv, kind, exp) => F.TyAbsExp (tv, kind, doExp exp) | F.TyAppExp (exp, ty) => F.TyAppExp (doExp exp, ty) | F.PackExp { payloadTy, exp, packageTy } => F.PackExp { payloadTy = payloadTy, exp = doExp exp, packageTy = packageTy } - | F.CaseExp { sourceSpan, subjectExp, subjectTy, matches = [(F.VarPat (span2, vid, ty'), exp2 as F.VarExp vid')], matchType, resultTy } => + | F.CaseExp { sourceSpan = _, subjectExp, subjectTy = _, matches = [(F.VarPat (_, vid, ty'), exp2 as F.VarExp vid')], matchType = _, resultTy = _ } => if TypedSyntax.eqVId (vid, vid') then doExp subjectExp else @@ -86,13 +86,13 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D | doDec (F.RecValDec valbinds) = F.RecValDec (List.map (fn (v, ty, exp) => (v, ty, doExp exp)) valbinds) | doDec (F.UnpackDec (tv, kind, vid, ty, exp)) = F.UnpackDec (tv, kind, vid, ty, doExp exp) | doDec (F.IgnoreDec exp) = F.IgnoreDec (doExp exp) - | doDec (dec as F.DatatypeDec datbinds) = dec - | doDec (dec as F.ExceptionDec { name, tagName, payloadTy }) = dec + | doDec (dec as F.DatatypeDec _) = dec + | doDec (dec as F.ExceptionDec _) = dec | doDec (dec as F.ESImportDec _) = dec - and genMatcher exp _ (F.WildcardPat _) : F.Exp = F.VarExp InitialEnv.VId_true (* always match *) - | genMatcher exp ty (F.SConPat { sourceSpan, scon, equality, cookedValue }) = F.AppExp (equality, F.TupleExp [exp, cookedValue]) - | genMatcher exp ty (F.VarPat (_, vid, _)) = F.VarExp InitialEnv.VId_true (* always match *) - | genMatcher exp (recordTy as F.RecordType fieldTypes) (F.RecordPat { sourceSpan, fields, ellipsis = NONE, allFields }) + and genMatcher _ _ (F.WildcardPat _) : F.Exp = F.VarExp InitialEnv.VId_true (* always match *) + | genMatcher exp _ (F.SConPat { sourceSpan = _, scon = _, equality, cookedValue }) = F.AppExp (equality, F.TupleExp [exp, cookedValue]) + | genMatcher _ _ (F.VarPat (_, _, _)) = F.VarExp InitialEnv.VId_true (* always match *) + | genMatcher exp (recordTy as F.RecordType fieldTypes) (F.RecordPat { sourceSpan, fields, ellipsis = NONE, allFields = _ }) = List.foldr (fn ((label, pat), e) => case Syntax.LabelMap.find (fieldTypes, label) of SOME fieldTy => let val exp = genMatcher (F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) fieldTy pat @@ -102,9 +102,9 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D ) (F.VarExp InitialEnv.VId_true) fields - | genMatcher exp (recordTy as F.RecordType fieldTypes) (F.RecordPat { sourceSpan, fields, ellipsis = SOME basePat, allFields }) + | genMatcher exp (recordTy as F.RecordType fieldTypes) (F.RecordPat { sourceSpan, fields, ellipsis = SOME basePat, allFields = _ }) = let val restTypes = List.foldl (fn ((label, _), fieldTypes) => #1 (Syntax.LabelMap.remove (fieldTypes, label))) fieldTypes fields - val restExp = F.RecordExp (Syntax.LabelMap.foldri (fn (label, fieldTy, xs) => (label, F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) :: xs) [] restTypes) + val restExp = F.RecordExp (Syntax.LabelMap.foldri (fn (label, _, xs) => (label, F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) :: xs) [] restTypes) val init = genMatcher restExp (F.RecordType restTypes) basePat in List.foldr (fn ((label, pat), e) => case Syntax.LabelMap.find (fieldTypes, label) of @@ -116,12 +116,12 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D init fields end - | genMatcher exp _ (F.RecordPat { sourceSpan, fields, ellipsis, allFields }) = raise DesugarError ([sourceSpan], "internal error: record pattern against non-record type") + | genMatcher _ _ (F.RecordPat { sourceSpan, fields = _, ellipsis = _, allFields = _ }) = raise DesugarError ([sourceSpan], "internal error: record pattern against non-record type") | genMatcher exp ty (F.ValConPat { sourceSpan, info, payload = SOME (payloadTy, payloadPat) }) = (case info of { representation = Syntax.REP_LIST, tag = "::", ... } => let val elemTy = case ty of - F.AppType { applied, arg } => arg + F.AppType { applied = _, arg } => arg | _ => raise DesugarError ([sourceSpan], "internal error: nil pattern with invalid type") val hdExp = F.PrimExp (F.PrimCall Primitives.List_unsafeHead, [elemTy], [exp]) val tlExp = F.PrimExp (F.PrimCall Primitives.List_unsafeTail, [elemTy], [exp]) @@ -146,7 +146,7 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D | { representation = Syntax.REP_BOOL, tag = "false", ... } => F.PrimExp (F.PrimCall Primitives.Bool_not, [], [exp]) | { representation = Syntax.REP_LIST, tag = "nil", ... } => let val elemTy = case ty of - F.AppType { applied, arg } => arg + F.AppType { applied = _, arg } => arg | _ => raise DesugarError ([sourceSpan], "internal error: nil pattern with invalid type") in F.PrimExp (F.PrimCall Primitives.List_null, [elemTy], [exp]) end @@ -158,14 +158,14 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D in F.PrimExp (F.PrimCall equalTag, [], [F.PrimExp (dataTagOp info, [], [exp]), F.AsciiStringAsDatatypeTag (#targetInfo ctx, tag)]) end ) - | genMatcher exp ty (F.ExnConPat { sourceSpan = _, tagPath = tag, payload = SOME (payloadTy, payloadPat) }) + | genMatcher exp _ (F.ExnConPat { sourceSpan = _, tagPath = tag, payload = SOME (payloadTy, payloadPat) }) = let val payload = genMatcher (F.PrimExp (F.ExnPayloadOp, [payloadTy], [exp])) payloadTy payloadPat in F.SimplifyingAndalsoExp (F.PrimExp (F.PrimCall Primitives.Exception_instanceof, [], [exp, tag]), payload) end - | genMatcher exp ty (F.ExnConPat { sourceSpan = _, tagPath = tag, payload = NONE }) + | genMatcher exp _ (F.ExnConPat { sourceSpan = _, tagPath = tag, payload = NONE }) = F.PrimExp (F.PrimCall Primitives.Exception_instanceof, [], [exp, tag]) - | genMatcher exp ty0 (F.LayeredPat (span, vid, ty1, innerPat)) = genMatcher exp ty0 innerPat - | genMatcher exp ty0 (F.VectorPat (span, pats, ellipsis, elemTy)) + | genMatcher exp ty0 (F.LayeredPat (_, _, _ (* ty1 *), innerPat)) = genMatcher exp ty0 innerPat + | genMatcher exp _ (F.VectorPat (_, pats, ellipsis, elemTy)) = let val vectorLengthExp = F.PrimExp (F.PrimCall (Primitives.Vector_length Primitives.INT), [elemTy], [exp]) val intTy = F.TyCon ([], Typing.primTyName_int) val expectedLengthExp = F.IntConstExp (Int.toLarge (Vector.length pats), intTy) @@ -178,22 +178,22 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D end ) e0 pats end - and genBinders exp ty (F.WildcardPat _) = [] - | genBinders exp ty (F.SConPat _) = [] - | genBinders exp _ (F.VarPat (span, vid, ty)) = [(vid, SOME ty, exp)] - | genBinders exp (F.RecordType fieldTypes) (F.RecordPat { sourceSpan, fields, ellipsis = NONE, allFields }) = List.concat (List.map (fn (label, innerPat) => genBinders (F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) (Syntax.LabelMap.lookup (fieldTypes, label)) innerPat) fields) - | genBinders exp (F.RecordType fieldTypes) (F.RecordPat { sourceSpan, fields, ellipsis = SOME basePat, allFields }) + and genBinders _ _ (F.WildcardPat _) = [] + | genBinders _ _ (F.SConPat _) = [] + | genBinders exp _ (F.VarPat (_, vid, ty)) = [(vid, SOME ty, exp)] + | genBinders exp (F.RecordType fieldTypes) (F.RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields = _ }) = List.concat (List.map (fn (label, innerPat) => genBinders (F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) (Syntax.LabelMap.lookup (fieldTypes, label)) innerPat) fields) + | genBinders exp (F.RecordType fieldTypes) (F.RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields = _ }) = let val restTypes = List.foldl (fn ((label, _), fieldTypes) => #1 (Syntax.LabelMap.remove (fieldTypes, label))) fieldTypes fields - val restExp = F.RecordExp (Syntax.LabelMap.foldri (fn (label, fieldTy, xs) => (label, F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) :: xs) [] restTypes) + val restExp = F.RecordExp (Syntax.LabelMap.foldri (fn (label, _, xs) => (label, F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) :: xs) [] restTypes) in genBinders restExp (F.RecordType restTypes) basePat @ List.concat (List.map (fn (label, innerPat) => genBinders (F.ProjectionExp { label = label, record = exp, fieldTypes = fieldTypes }) (Syntax.LabelMap.lookup (fieldTypes, label)) innerPat) fields) end - | genBinders exp _ (F.RecordPat { sourceSpan, fields, ellipsis, allFields }) = raise DesugarError ([sourceSpan], "internal error: record pattern against non-record type") + | genBinders _ _ (F.RecordPat { sourceSpan, fields = _, ellipsis = _, allFields = _ }) = raise DesugarError ([sourceSpan], "internal error: record pattern against non-record type") | genBinders exp ty (F.ValConPat { sourceSpan, info, payload = SOME (payloadTy, payloadPat) }) = (case info of { representation = Syntax.REP_REF, tag = "ref", ... } => genBinders (F.PrimExp (F.PrimCall Primitives.Ref_read, [payloadTy], [exp])) payloadTy payloadPat | { representation = Syntax.REP_LIST, tag = "::", ... } => let val elemTy = case ty of - F.AppType { applied, arg } => arg + F.AppType { applied = _, arg } => arg | _ => raise DesugarError ([sourceSpan], "internal error: nil pattern with invalid type") val hdExp = F.PrimExp (F.PrimCall Primitives.List_unsafeHead, [elemTy], [exp]) val tlExp = F.PrimExp (F.PrimCall Primitives.List_unsafeTail, [elemTy], [exp]) @@ -201,22 +201,22 @@ fun desugarPatternMatches (ctx: Context) : { doExp : F.Exp -> F.Exp, doDec : F.D end | _ => genBinders (F.PrimExp (F.DataPayloadOp info, [payloadTy], [exp])) payloadTy payloadPat ) - | genBinders exp ty (F.ValConPat { sourceSpan, info, payload = NONE }) = [] - | genBinders exp ty (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (payloadTy, payloadPat) }) = genBinders (F.PrimExp (F.ExnPayloadOp, [payloadTy], [exp])) payloadTy payloadPat - | genBinders exp ty (F.ExnConPat { sourceSpan = _, tagPath, payload = NONE }) = [] - | genBinders exp _ (F.LayeredPat (span, vid, ty, pat)) = (vid, SOME ty, exp) :: genBinders exp ty pat - | genBinders exp ty (F.VectorPat (span, pats, ellipsis, elemTy)) = let val intTy = F.TyCon ([], Typing.primTyName_int) - in Vector.foldri (fn (i, pat, acc) => genBinders (F.PrimExp (F.PrimCall (Primitives.Unsafe_Vector_sub Primitives.INT), [elemTy], [exp, F.IntConstExp (Int.toLarge i, intTy)])) elemTy pat @ acc) [] pats - end + | genBinders _ _ (F.ValConPat { sourceSpan = _, info = _, payload = NONE }) = [] + | genBinders exp _ (F.ExnConPat { sourceSpan = _, tagPath = _, payload = SOME (payloadTy, payloadPat) }) = genBinders (F.PrimExp (F.ExnPayloadOp, [payloadTy], [exp])) payloadTy payloadPat + | genBinders _ _ (F.ExnConPat { sourceSpan = _, tagPath = _, payload = NONE }) = [] + | genBinders exp _ (F.LayeredPat (_, vid, ty, pat)) = (vid, SOME ty, exp) :: genBinders exp ty pat + | genBinders exp _ (F.VectorPat (_, pats, _, elemTy)) = let val intTy = F.TyCon ([], Typing.primTyName_int) + in Vector.foldri (fn (i, pat, acc) => genBinders (F.PrimExp (F.PrimCall (Primitives.Unsafe_Vector_sub Primitives.INT), [elemTy], [exp, F.IntConstExp (Int.toLarge i, intTy)])) elemTy pat @ acc) [] pats + end and isExhaustive (F.WildcardPat _) = true | isExhaustive (F.SConPat _) = false | isExhaustive (F.VarPat _) = true - | isExhaustive (F.RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields }) = List.all (fn (_, e) => isExhaustive e) fields - | isExhaustive (F.RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields }) = isExhaustive basePat andalso List.all (fn (_, e) => isExhaustive e) fields + | isExhaustive (F.RecordPat { sourceSpan = _, fields, ellipsis = NONE, allFields = _ }) = List.all (fn (_, e) => isExhaustive e) fields + | isExhaustive (F.RecordPat { sourceSpan = _, fields, ellipsis = SOME basePat, allFields = _ }) = isExhaustive basePat andalso List.all (fn (_, e) => isExhaustive e) fields | isExhaustive (F.ValConPat _) = false (* TODO *) | isExhaustive (F.ExnConPat _) = false | isExhaustive (F.LayeredPat (_, _, _, innerPat)) = isExhaustive innerPat - | isExhaustive (F.VectorPat (_, pats, ellipsis, elemTy)) = ellipsis andalso Vector.length pats = 0 + | isExhaustive (F.VectorPat (_, pats, ellipsis, _)) = ellipsis andalso Vector.length pats = 0 fun doDecs decs = List.map doDec decs in { doExp = doExp , doDec = doDec @@ -229,7 +229,6 @@ structure DecomposeValRec :> sig val doExp : FSyntax.Exp -> FSyntax.Exp end = struct structure F = FSyntax -type Context = {} fun doExp (F.PrimExp (primOp, tyargs, args)) = F.PrimExp (primOp, tyargs, List.map doExp args) | doExp (exp as F.VarExp _) = exp | doExp (F.RecordExp fields) = F.RecordExp (List.map (fn (label, exp) => (label, doExp exp)) fields) @@ -252,7 +251,7 @@ fun doExp (F.PrimExp (primOp, tyargs, args)) = F.PrimExp (primOp, tyargs, List.m | doExp (F.ExportModule entities) = F.ExportModule (Vector.map (fn (name, exp) => (name, doExp exp)) entities) and doDec (F.ValDec (vid, optTy, exp)) = [F.ValDec (vid, optTy, doExp exp)] | doDec (F.RecValDec valbinds) - = let val bound = List.foldl (fn ((vid, ty, exp), set) => TypedSyntax.VIdSet.add (set, vid)) TypedSyntax.VIdSet.empty valbinds + = let val bound = List.foldl (fn ((vid, _, _), set) => TypedSyntax.VIdSet.add (set, vid)) TypedSyntax.VIdSet.empty valbinds val map = List.foldl (fn (def as (vid, _, exp), map) => TypedSyntax.VIdMap.insert (map, vid, { def = def , dests = TypedSyntax.VIdSet.intersection (F.freeVarsInExp (TypedSyntax.VIdSet.empty, exp) TypedSyntax.VIdSet.empty, bound) @@ -277,7 +276,7 @@ and doDec (F.ValDec (vid, optTy, exp)) = [F.ValDec (vid, optTy, doExp exp)] | doDec (F.DatatypeDec datbinds) = [F.DatatypeDec datbinds] | doDec (F.ExceptionDec names) = [F.ExceptionDec names] | doDec (dec as F.ESImportDec _) = [dec] -and doDecs decs = List.foldr (fn (dec, rest) => doDec dec @ rest) [] decs +(* and doDecs decs = List.foldr (fn (dec, rest) => doDec dec @ rest) [] decs *) end structure DeadCodeElimination :> sig @@ -309,19 +308,19 @@ fun isDiscardablePrimOp (F.IntConstOp _) = true | isDiscardablePrimOp F.LuaCallOp = false | isDiscardablePrimOp F.LuaCall1Op = false | isDiscardablePrimOp (F.LuaMethodOp _) = false -fun isDiscardable (F.PrimExp (primOp, tyargs, args)) = isDiscardablePrimOp primOp andalso List.all isDiscardable args +fun isDiscardable (F.PrimExp (primOp, _, args)) = isDiscardablePrimOp primOp andalso List.all isDiscardable args | isDiscardable (F.VarExp _) = true - | isDiscardable (F.RecordExp fields) = List.all (fn (label, exp) => isDiscardable exp) fields - | isDiscardable (F.LetExp (decs, exp)) = false (* TODO *) - | isDiscardable (F.AppExp (exp1, exp2)) = false (* TODO *) - | isDiscardable (F.HandleExp { body, exnName, handler }) = false (* TODO *) + | isDiscardable (F.RecordExp fields) = List.all (fn (_, exp) => isDiscardable exp) fields + | isDiscardable (F.LetExp (_, _)) = false (* TODO *) + | isDiscardable (F.AppExp (_, _)) = false (* TODO *) + | isDiscardable (F.HandleExp { body = _, exnName = _, handler = _ }) = false (* TODO *) | isDiscardable (F.IfThenElseExp (exp1, exp2, exp3)) = isDiscardable exp1 andalso isDiscardable exp2 andalso isDiscardable exp3 - | isDiscardable (F.CaseExp { sourceSpan = _, subjectExp, subjectTy = _, matches, matchType = _, resultTy = _ }) = false (* TODO *) - | isDiscardable (F.FnExp (vid, ty, exp)) = true - | isDiscardable (F.ProjectionExp { label, record, fieldTypes }) = isDiscardable record - | isDiscardable (F.TyAbsExp (tyvar, kind, exp)) = isDiscardable exp - | isDiscardable (F.TyAppExp (exp, ty)) = isDiscardable exp - | isDiscardable (F.PackExp { payloadTy, exp, packageTy }) = isDiscardable exp + | isDiscardable (F.CaseExp { sourceSpan = _, subjectExp = _, subjectTy = _, matches = _, matchType = _, resultTy = _ }) = false (* TODO *) + | isDiscardable (F.FnExp (_, _, _)) = true + | isDiscardable (F.ProjectionExp { label = _, record, fieldTypes = _ }) = isDiscardable record + | isDiscardable (F.TyAbsExp (_, _, exp)) = isDiscardable exp + | isDiscardable (F.TyAppExp (exp, _)) = isDiscardable exp + | isDiscardable (F.PackExp { payloadTy = _, exp, packageTy = _ }) = isDiscardable exp | isDiscardable (F.BogusExp _) = false | isDiscardable F.ExitProgram = false | isDiscardable (F.ExportValue _) = false @@ -331,18 +330,18 @@ val doPat : F.Pat -> TypedSyntax.VIdSet.set -> (* constructors used *) TypedSynt and doExp : F.Exp -> TypedSyntax.VIdSet.set -> TypedSyntax.VIdSet.set * F.Exp and doIgnoredExp : F.Exp -> TypedSyntax.VIdSet.set -> TypedSyntax.VIdSet.set * F.Exp list and doDec : TypedSyntax.VIdSet.set * F.Dec -> TypedSyntax.VIdSet.set * F.Dec list -and doDecs : TypedSyntax.VIdSet.set * F.Dec list -> TypedSyntax.VIdSet.set * F.Dec list +(* and doDecs : TypedSyntax.VIdSet.set * F.Dec list -> TypedSyntax.VIdSet.set * F.Dec list *) *) fun doPat (F.WildcardPat _) acc = acc | doPat (F.SConPat { sourceSpan = _, scon = _, equality, cookedValue }) acc = #1 (doExp equality (#1 (doExp cookedValue acc))) | doPat (F.VarPat _) acc = acc - | doPat (F.RecordPat { sourceSpan = _, fields, ellipsis, allFields }) acc = List.foldl (fn ((label, pat), acc) => doPat pat acc) (case ellipsis of NONE => acc | SOME basePat => doPat basePat acc) fields - | doPat (F.ValConPat { sourceSpan = _, info, payload = NONE }) acc = acc - | doPat (F.ValConPat { sourceSpan = _, info, payload = SOME (payloadTy, payloadPat) }) acc = doPat payloadPat acc + | doPat (F.RecordPat { sourceSpan = _, fields, ellipsis, allFields = _ }) acc = List.foldl (fn ((_, pat), acc) => doPat pat acc) (case ellipsis of NONE => acc | SOME basePat => doPat basePat acc) fields + | doPat (F.ValConPat { sourceSpan = _, info = _, payload = NONE }) acc = acc + | doPat (F.ValConPat { sourceSpan = _, info = _, payload = SOME (_, payloadPat) }) acc = doPat payloadPat acc | doPat (F.ExnConPat { sourceSpan = _, tagPath, payload = NONE }) acc = #1 (doExp tagPath acc) - | doPat (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (payloadTy, payloadPat) }) acc = doPat payloadPat (#1 (doExp tagPath acc)) - | doPat (F.LayeredPat (_, vid, ty, innerPat)) acc = doPat innerPat acc - | doPat (F.VectorPat (_, pats, ellipsis, elemTy)) acc = Vector.foldl (fn (pat, acc) => doPat pat acc) acc pats + | doPat (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (_, payloadPat) }) acc = doPat payloadPat (#1 (doExp tagPath acc)) + | doPat (F.LayeredPat (_, _, _, innerPat)) acc = doPat innerPat acc + | doPat (F.VectorPat (_, pats, _, _)) acc = Vector.foldl (fn (pat, acc) => doPat pat acc) acc pats and doExp (F.PrimExp (primOp, tyargs, args) : F.Exp) acc : TypedSyntax.VIdSet.set * F.Exp = let val (acc, args') = List.foldr (fn (x, (acc, xs)) => let val (acc, x) = doExp x acc in (acc, x :: xs) end) (acc, []) args in (acc, F.PrimExp (primOp, tyargs, args')) @@ -373,10 +372,10 @@ and doExp (F.PrimExp (primOp, tyargs, args) : F.Exp) acc : TypedSyntax.VIdSet.se end | doExp (F.CaseExp { sourceSpan, subjectExp, subjectTy, matches, matchType, resultTy }) acc = let val (used, subjectExp) = doExp subjectExp acc - val (used, matches) = List.foldr (fn ((pat, exp), (used, matches)) => let val (used', exp) = doExp exp acc - in (doPat pat used', (pat, exp) :: matches) - end) - (used, []) matches + val (_, matches) = List.foldr (fn ((pat, exp), (used, matches)) => let val (used', exp) = doExp exp used + in (doPat pat used', (pat, exp) :: matches) + end) + (used, []) matches in (used, F.CaseExp { sourceSpan = sourceSpan, subjectExp = subjectExp, subjectTy = subjectTy, matches = matches, matchType = matchType, resultTy = resultTy }) end | doExp (F.FnExp (vid, ty, exp)) acc = let val (used, exp) = doExp exp acc @@ -405,7 +404,7 @@ and doExp (F.PrimExp (primOp, tyargs, args) : F.Exp) acc : TypedSyntax.VIdSet.se and doIgnoredExpAsExp exp acc = let val (used, exps) = doIgnoredExp exp acc in (used, F.LetExp (List.map F.IgnoreDec exps, F.RecordExp [])) end -and doIgnoredExp (exp as F.PrimExp (primOp, tyargs, args)) acc +and doIgnoredExp (exp as F.PrimExp (primOp, _, args)) acc = if isDiscardablePrimOp primOp then List.foldr (fn (x, (acc, xs)) => let val (acc, ys) = doIgnoredExp x acc in (acc, ys @ xs) end) (acc, []) args else @@ -413,7 +412,7 @@ and doIgnoredExp (exp as F.PrimExp (primOp, tyargs, args)) acc in (used, [exp]) end | doIgnoredExp (F.VarExp _) acc = (acc, []) - | doIgnoredExp (F.RecordExp fields) acc = List.foldr (fn ((label, exp), (acc, xs)) => let val (acc, ys) = doIgnoredExp exp acc in (acc, ys @ xs) end) (acc, []) fields + | doIgnoredExp (F.RecordExp fields) acc = List.foldr (fn ((_, exp), (acc, xs)) => let val (acc, ys) = doIgnoredExp exp acc in (acc, ys @ xs) end) (acc, []) fields | doIgnoredExp (F.LetExp (decs, exp)) acc = let val (used, exp) = doIgnoredExpAsExp exp TypedSyntax.VIdSet.empty val (used, decs) = List.foldr (fn (dec, (used, decs)) => let val (used, decs') = doDec (used, dec) in (used, decs' @ decs) @@ -451,7 +450,7 @@ and doIgnoredExp (exp as F.PrimExp (primOp, tyargs, args)) acc in (used, [F.CaseExp { sourceSpan = sourceSpan, subjectExp = subjectExp, subjectTy = subjectTy, matches = matches, matchType = matchType, resultTy = resultTy }]) end | doIgnoredExp (F.FnExp _) acc = (acc, []) - | doIgnoredExp (F.ProjectionExp { label, record, fieldTypes }) acc = doIgnoredExp record acc + | doIgnoredExp (F.ProjectionExp { label = _, record, fieldTypes = _ }) acc = doIgnoredExp record acc | doIgnoredExp (F.TyAbsExp (tyvar, kind, exp)) acc = let val (used, exp) = doIgnoredExpAsExp exp acc (* should be pure *) in case exp of F.RecordExp [] => (used, []) @@ -514,24 +513,24 @@ and doDec (used : TypedSyntax.VIdSet.set, F.ValDec (vid, optTy, exp)) : TypedSyn | doDec (used, F.IgnoreDec exp) = let val (used', exps) = doIgnoredExp exp used in (used', List.map F.IgnoreDec exps) end - | doDec (used, dec as F.DatatypeDec datbinds) = (used, [dec]) (* TODO *) - | doDec (used, dec as F.ExceptionDec { name, tagName, payloadTy }) = if TypedSyntax.VIdSet.member (used, tagName) then - (used, [dec]) - else - (used, []) + | doDec (used, dec as F.DatatypeDec _) = (used, [dec]) (* TODO *) + | doDec (used, dec as F.ExceptionDec { name = _, tagName, payloadTy = _ }) = if TypedSyntax.VIdSet.member (used, tagName) then + (used, [dec]) + else + (used, []) | doDec (used, F.ESImportDec { pure, specs, moduleName }) - = let val specs = List.filter (fn (name, vid, ty) => TypedSyntax.VIdSet.member (used, vid)) specs + = let val specs = List.filter (fn (_, vid, _) => TypedSyntax.VIdSet.member (used, vid)) specs in (used, if pure andalso List.null specs then [] else [F.ESImportDec { pure = pure, specs = specs, moduleName = moduleName }]) end -and doDecs (used, decs) = List.foldr (fn (dec, (used, decs)) => let val (used, dec) = doDec (used, dec) +(* and doDecs (used, decs) = List.foldr (fn (dec, (used, decs)) => let val (used, dec) = doDec (used, dec) in (used, dec @ decs) - end) (used, []) decs -and definedInDecs decs acc = List.foldl (fn (dec, s) => definedInDec dec s) acc decs -and definedInDec (F.ValDec (vid, _, _)) acc = TypedSyntax.VIdSet.add (acc, vid) + end) (used, []) decs *) +(* and definedInDecs decs acc = List.foldl (fn (dec, s) => definedInDec dec s) acc decs *) +(* and definedInDec (F.ValDec (vid, _, _)) acc = TypedSyntax.VIdSet.add (acc, vid) | definedInDec (F.RecValDec valbinds) acc = List.foldl (fn ((vid, _, _), s) => TypedSyntax.VIdSet.add (s, vid)) acc valbinds - | definedInDec (F.UnpackDec (tv, kind, vid, ty, exp)) acc = TypedSyntax.VIdSet.add (acc, vid) + | definedInDec (F.UnpackDec (_, _, vid, _, _)) acc = TypedSyntax.VIdSet.add (acc, vid) | definedInDec (F.IgnoreDec _) acc = acc - | definedInDec (F.DatatypeDec datbinds) acc = List.foldl (fn (F.DatBind (tyvars, tycon, conbinds), s) => List.foldl (fn (F.ConBind (vid, _), s) => TypedSyntax.VIdSet.add (s, vid)) s conbinds) acc datbinds + | definedInDec (F.DatatypeDec datbinds) acc = List.foldl (fn (F.DatBind (_, _, conbinds), s) => List.foldl (fn (F.ConBind (vid, _), s) => TypedSyntax.VIdSet.add (s, vid)) s conbinds) acc datbinds | definedInDec (F.ExceptionDec { name = _, tagName, payloadTy = _ }) acc = TypedSyntax.VIdSet.add (acc, tagName) - | definedInDec (F.ESImportDec { pure, specs, moduleName }) acc = List.foldl (fn ((_, vid, _), acc) => TypedSyntax.VIdSet.add (acc, vid)) acc specs + | definedInDec (F.ESImportDec { pure = _, specs, moduleName = _ }) acc = List.foldl (fn ((_, vid, _), acc) => TypedSyntax.VIdSet.add (acc, vid)) acc specs *) end; (* structure DeadCodeElimination *) diff --git a/src/initfile.sml b/src/initfile.sml index 4bab1f62..b4862210 100644 --- a/src/initfile.sml +++ b/src/initfile.sml @@ -66,7 +66,7 @@ fun readFile (lang, path) | NONE => go ({ provides = provides, requires = requires, body = String.concat (List.rev acc) } :: chunks) in go [] before TextIO.closeIn ins end -fun doEliminate (chunk as { provides, requires, body }, (acc, used)) +fun doEliminate (chunk as { provides, requires, body = _ }, (acc, used)) = if List.exists (fn p => StringSet.member (used, p)) provides then (chunk :: acc, List.foldl StringSet.add' used requires) else @@ -74,7 +74,7 @@ fun doEliminate (chunk as { provides, requires, body }, (acc, used)) fun eliminateUnusedChunks (chunks, used) = let val usedSet = List.foldl StringSet.add' StringSet.empty used in #1 (List.foldr doEliminate ([], usedSet) chunks) end -fun output (outs, chunks) = let fun outputOne { provides, requires, body } = TextIO.output (outs, body) +fun output (outs, chunks) = let fun outputOne { provides = _, requires = _, body } = TextIO.output (outs, body) in List.app outputOne chunks end end; diff --git a/src/initialenv.sml b/src/initialenv.sml index 95481fed..7fe853e2 100644 --- a/src/initialenv.sml +++ b/src/initialenv.sml @@ -116,7 +116,7 @@ fun newVId name = let val n = !vidCounter end (* Ref *) -val VId_ref = Typing.VId_ref +(* val VId_ref = Typing.VId_ref *) (* Bool *) val VId_true = newVId "true" @@ -124,7 +124,7 @@ val VId_false = newVId "false" (* List *) val VId_nil = newVId "nil" -val VId_DCOLON = Typing.VId_DCOLON +(* val VId_DCOLON = Typing.VId_DCOLON *) (* Exception *) val VId_Match = newVId "Match" @@ -225,8 +225,6 @@ val VId_DelimCont_topLevel = newVId "_Prim.DelimCont.topLevel" val initialEnv : Typing.Env = let open Typing - val mkTyMap = List.foldl Syntax.TyConMap.insert' Syntax.TyConMap.empty - val mkValMap = List.foldl (fn ((vid, tysc), m) => Syntax.VIdMap.insert(m, Syntax.MkVId vid, (tysc, Syntax.ValueVariable))) Syntax.VIdMap.empty fun mkValConMap (cons, rep) = let val allConstructors = List.foldl (fn ((vid, _), set) => Syntax.VIdSet.add (set, Syntax.MkVId vid)) Syntax.VIdSet.empty cons val constructorsWithPayload = List.foldl (fn ((vid, TypedSyntax.TypeScheme (_, TypedSyntax.FnType _)), set) => Syntax.VIdSet.add (set, Syntax.MkVId vid) | (_, set) => set) Syntax.VIdSet.empty cons in List.foldl (fn ((vid, tysc), m) => let val idstatus = Syntax.ValueConstructor { tag = vid, allConstructors = allConstructors, constructorsWithPayload = constructorsWithPayload, representation = rep } @@ -257,7 +255,6 @@ val initialEnv : Typing.Env fun mkFnType (a, b) = TypedSyntax.FnType (SourcePos.nullSpan, a, b) val op --> = mkFnType fun mkPairType (a, b) = TypedSyntax.PairType (SourcePos.nullSpan, a, b) - fun mkTupleType xs = TypedSyntax.TupleType (SourcePos.nullSpan, xs) fun mkTyCon (a, b) = TypedSyntax.TyCon (SourcePos.nullSpan, a, b) fun refOf(t) = mkTyCon([t], primTyName_ref) fun listOf(t) = mkTyCon([t], primTyName_list) @@ -419,9 +416,7 @@ val primOverloadEnv : Typing.Env val TypeScheme = TypedSyntax.TypeScheme fun mkTyVar tv = TypedSyntax.TyVar (SourcePos.nullSpan, tv) val tyVarA = TypedSyntax.MkTyVar ("'a", 0) - val tyVarEqA = TypedSyntax.MkTyVar ("''a", 0) val tyA = mkTyVar tyVarA - val tyEqA = mkTyVar tyVarEqA infixr --> fun a --> b = TypedSyntax.FnType (SourcePos.nullSpan, a, b) fun mkPairType (a, b) = TypedSyntax.PairType (SourcePos.nullSpan, a, b) diff --git a/src/js-syntax.sml b/src/js-syntax.sml index 227ae1fe..ef8ba817 100644 --- a/src/js-syntax.sml +++ b/src/js-syntax.sml @@ -95,7 +95,7 @@ fun compare (PredefinedId x, PredefinedId y) = String.compare (x, y) | compare (UserDefinedId x, UserDefinedId y) = TypedSyntax.VIdKey.compare (x, y) end : ORD_KEY structure IdSet = RedBlackSetFn (IdKey) -structure IdMap = RedBlackMapFn (IdKey) +(* structure IdMap = RedBlackMapFn (IdKey) *) datatype JsConst = Null | False | True @@ -327,7 +327,7 @@ val LogicalORExpression = 15 val UnaryExpression = 4 val CallExpression = 2 val MemberExpression = 1 -val PrimaryExpression = 0 +(* val PrimaryExpression = 0 *) end datatype Fragment = Fragment of string @@ -339,7 +339,7 @@ fun findNextFragment [] = NONE | findNextFragment (Fragment "" :: fragments) = findNextFragment fragments | findNextFragment (Fragment s :: _) = SOME s | findNextFragment (_ :: fragments) = findNextFragment fragments -fun processIndent (revAcc, indent, []) = List.rev revAcc +fun processIndent (revAcc, _, []) = List.rev revAcc | processIndent (revAcc, indent, Fragment s :: fragments) = processIndent (s :: revAcc, indent, fragments) | processIndent (revAcc, indent, IncreaseIndent :: fragments) = processIndent (revAcc, indent + 1, fragments) | processIndent (revAcc, indent, DecreaseIndent :: fragments) = processIndent (revAcc, indent - 1, fragments) @@ -410,15 +410,15 @@ fun doConst S.Null = (fn rest => Fragment "null" :: rest) | doConst S.True = (fn rest => Fragment "true" :: rest) | doConst (S.Numeral s) = (fn rest => Fragment s :: rest) | doConst (S.WideString s) = (fn rest => Fragment (toWideStringLit s) :: rest) -fun doExp (prec, S.ConstExp ct) : Fragment list -> Fragment list = doConst ct - | doExp (prec, S.ThisExp) = (fn rest => Fragment "this" :: rest) - | doExp (prec, S.VarExp id) = (fn rest => Fragment (idToJs id) :: rest) - | doExp (prec, S.ObjectExp fields) = (fn rest => Fragment "{" :: commaSepV (Vector.map (fn (key, value) => fn rest => Fragment (doKey key) :: Fragment ": " :: doExp (Precedence.AssignmentExpression, value) rest) fields) (Fragment "}" :: rest)) - | doExp (prec, S.ArrayExp elements) = (fn rest => Fragment "[" :: doCommaSepExp elements (Fragment "]" :: rest)) +fun doExp (_, S.ConstExp ct) : Fragment list -> Fragment list = doConst ct + | doExp (_, S.ThisExp) = (fn rest => Fragment "this" :: rest) + | doExp (_, S.VarExp id) = (fn rest => Fragment (idToJs id) :: rest) + | doExp (_, S.ObjectExp fields) = (fn rest => Fragment "{" :: commaSepV (Vector.map (fn (key, value) => fn rest => Fragment (doKey key) :: Fragment ": " :: doExp (Precedence.AssignmentExpression, value) rest) fields) (Fragment "}" :: rest)) + | doExp (_, S.ArrayExp elements) = (fn rest => Fragment "[" :: doCommaSepExp elements (Fragment "]" :: rest)) | doExp (prec, S.CallExp (fnExp, arguments)) = paren (prec < Precedence.CallExpression) (fn rest => doExp (Precedence.CallExpression, fnExp) (Fragment "(" :: doCommaSepExp arguments (Fragment ")" :: rest))) | doExp (prec, S.MethodExp (objectExp, methodName, arguments)) = paren (prec < Precedence.CallExpression) (fn rest => doExp (Precedence.MemberExpression, objectExp) (Fragment "." :: Fragment methodName :: Fragment "(" :: doCommaSepExp arguments (Fragment ")" :: rest))) | doExp (prec, S.NewExp (constructorExp, arguments)) = paren (prec < Precedence.MemberExpression) (fn rest => Fragment "new " :: doExp (Precedence.MemberExpression, constructorExp) (Fragment "(" :: doCommaSepExp arguments (Fragment ")" :: rest))) - | doExp (prec, S.FunctionExp (parameters, body)) = (fn rest => Fragment "function" :: Fragment "(" :: commaSepV (Vector.map (fn id => fn rest => Fragment (idToJs id) :: rest) parameters) (Fragment ") {" :: IncreaseIndent :: LineTerminator :: doBlock body (DecreaseIndent :: Indent :: Fragment "}" :: rest))) + | doExp (_, S.FunctionExp (parameters, body)) = (fn rest => Fragment "function" :: Fragment "(" :: commaSepV (Vector.map (fn id => fn rest => Fragment (idToJs id) :: rest) parameters) (Fragment ") {" :: IncreaseIndent :: LineTerminator :: doBlock body (DecreaseIndent :: Indent :: Fragment "}" :: rest))) | doExp (prec, S.BinExp (binOp, x, y)) = (case binOpInfo binOp of InfixOp (prec', symbol) => paren (prec < prec') (fn rest => doExp (prec', x) (Fragment " " :: Fragment symbol :: Fragment " " :: doExp (prec' - 1, y) rest)) | InfixOpR (prec', symbol) => paren (prec < prec') (fn rest => doExp (prec' - 1, x) (Fragment " " :: Fragment symbol :: Fragment " " :: doExp (prec', y) rest)) @@ -436,7 +436,7 @@ fun doExp (prec, S.ConstExp ct) : Fragment list -> Fragment list = doConst ct | doExp (prec, S.IndexExp (objectExp, indexExp)) = let val tryIdentifierName = case indexExp of S.ConstExp (S.WideString name) => - let val name = Vector.foldr (fn (c, NONE) => NONE + let val name = Vector.foldr (fn (_, NONE) => NONE | (c, SOME xs) => if c < 128 then SOME (chr c :: xs) else diff --git a/src/js-transform.sml b/src/js-transform.sml index 97c56c61..46e5916f 100644 --- a/src/js-transform.sml +++ b/src/js-transform.sml @@ -11,13 +11,13 @@ structure J = JsSyntax fun collectLetConstStat (J.LetStat vars) acc = Vector.foldl (fn ((vid, _), acc) => J.IdSet.add (acc, J.UserDefinedId vid)) acc vars | collectLetConstStat (J.ConstStat vars) acc = Vector.foldl (fn ((vid, _), acc) => J.IdSet.add (acc, J.UserDefinedId vid)) acc vars | collectLetConstStat (J.ExpStat _) acc = acc - | collectLetConstStat (J.IfStat (_, then', else')) acc = acc + | collectLetConstStat (J.IfStat _) acc = acc | collectLetConstStat (J.ReturnStat _) acc = acc - | collectLetConstStat (J.TryCatchStat (try, vid, catch)) acc = acc + | collectLetConstStat (J.TryCatchStat _) acc = acc | collectLetConstStat (J.ThrowStat _) acc = acc - | collectLetConstStat (J.BlockStat (_, block)) acc = acc - | collectLetConstStat (J.LoopStat (_, block)) acc = acc - | collectLetConstStat (J.SwitchStat (_, cases)) acc = acc + | collectLetConstStat (J.BlockStat _) acc = acc + | collectLetConstStat (J.LoopStat _) acc = acc + | collectLetConstStat (J.SwitchStat _) acc = acc | collectLetConstStat (J.BreakStat _) acc = acc | collectLetConstStat (J.ContinueStat _) acc = acc | collectLetConstStat (J.DefaultExportStat _) acc = acc @@ -30,7 +30,7 @@ fun freeVarsExp (_, J.ConstExp _) acc = acc acc else J.IdSet.add (acc, x) - | freeVarsExp (bound, J.ObjectExp fields) acc = Vector.foldl (fn ((key, exp), acc) => freeVarsExp (bound, exp) acc) acc fields + | freeVarsExp (bound, J.ObjectExp fields) acc = Vector.foldl (fn ((_, exp), acc) => freeVarsExp (bound, exp) acc) acc fields | freeVarsExp (bound, J.ArrayExp elems) acc = Vector.foldl (fn (exp, acc) => freeVarsExp (bound, exp) acc) acc elems | freeVarsExp (bound, J.CallExp (x, ys)) acc = Vector.foldl (fn (exp, acc) => freeVarsExp (bound, exp) acc) (freeVarsExp (bound, x) acc) ys | freeVarsExp (bound, J.MethodExp (x, _, ys)) acc = Vector.foldl (fn (exp, acc) => freeVarsExp (bound, exp) acc) (freeVarsExp (bound, x) acc) ys @@ -43,21 +43,21 @@ fun freeVarsExp (_, J.ConstExp _) acc = acc | freeVarsExp (bound, J.UnaryExp (_, x)) acc = freeVarsExp (bound, x) acc | freeVarsExp (bound, J.IndexExp (x, y)) acc = freeVarsExp (bound, x) (freeVarsExp (bound, y) acc) | freeVarsExp (bound, J.CondExp (x, y, z)) acc = freeVarsExp (bound, x) (freeVarsExp (bound, y) (freeVarsExp (bound, z) acc)) -and freeVarsStat (bound, J.LetStat vars) acc = Vector.foldl (fn ((vid, NONE), acc) => acc - | ((vid, SOME exp), acc) => freeVarsExp (bound, exp) acc +and freeVarsStat (bound, J.LetStat vars) acc = Vector.foldl (fn ((_, NONE), acc) => acc + | ((_, SOME exp), acc) => freeVarsExp (bound, exp) acc ) acc vars - | freeVarsStat (bound, J.ConstStat vars) acc = Vector.foldl (fn ((vid, exp), acc) => freeVarsExp (bound, exp) acc) acc vars + | freeVarsStat (bound, J.ConstStat vars) acc = Vector.foldl (fn ((_, exp), acc) => freeVarsExp (bound, exp) acc) acc vars | freeVarsStat (bound, J.ExpStat exp) acc = freeVarsExp (bound, exp) acc | freeVarsStat (bound, J.IfStat (cond, then', else')) acc = freeVarsExp (bound, cond) (freeVarsBlock (bound, then') (freeVarsBlock (bound, else') acc)) - | freeVarsStat (bound, J.ReturnStat NONE) acc = acc + | freeVarsStat (_, J.ReturnStat NONE) acc = acc | freeVarsStat (bound, J.ReturnStat (SOME exp)) acc = freeVarsExp (bound, exp) acc | freeVarsStat (bound, J.TryCatchStat (try, vid, catch)) acc = freeVarsBlock (bound, try) (freeVarsBlock (J.IdSet.add (bound, J.UserDefinedId vid), catch) acc) | freeVarsStat (bound, J.ThrowStat exp) acc = freeVarsExp (bound, exp) acc | freeVarsStat (bound, J.BlockStat (_, block)) acc = freeVarsBlock (bound, block) acc | freeVarsStat (bound, J.LoopStat (_, block)) acc = freeVarsBlock (bound, block) acc - | freeVarsStat (bound, J.SwitchStat (exp, cases)) acc = List.foldl (fn ((c, block), acc) => freeVarsBlock (bound, block) acc) (freeVarsExp (bound, exp) acc) cases - | freeVarsStat (bound, J.BreakStat _) acc = acc - | freeVarsStat (bound, J.ContinueStat _) acc = acc + | freeVarsStat (bound, J.SwitchStat (exp, cases)) acc = List.foldl (fn ((_, block), acc) => freeVarsBlock (bound, block) acc) (freeVarsExp (bound, exp) acc) cases + | freeVarsStat (_, J.BreakStat _) acc = acc + | freeVarsStat (_, J.ContinueStat _) acc = acc | freeVarsStat (bound, J.DefaultExportStat exp) acc = freeVarsExp (bound, exp) acc | freeVarsStat (bound, J.NamedExportStat entities) acc = Vector.foldl (fn ((x, _), acc) => if J.IdSet.member (bound, x) then acc @@ -75,9 +75,9 @@ fun freshVId (ctx : Context, name) = let val n = !(#nextVId ctx) in TypedSyntax.MkVId (name, n) end -fun goExp (ctx, bound, depth, e as J.ConstExp _) = ([], e) - | goExp (ctx, bound, depth, e as J.ThisExp) = ([], e) - | goExp (ctx, bound, depth, e as J.VarExp _) = ([], e) +fun goExp (_, _, _, e as J.ConstExp _) = ([], e) + | goExp (_, _, _, e as J.ThisExp) = ([], e) + | goExp (_, _, _, e as J.VarExp _) = ([], e) | goExp (ctx, bound, depth, J.ObjectExp fields) = let val (decs, fields') = Vector.foldr (fn ((key, exp), (decs, fields)) => let val (decs', exp') = goExp (ctx, bound, depth, exp) in (decs' @ decs, (key, exp') :: fields) @@ -162,10 +162,10 @@ and goStat (ctx, bound, depth, J.LetStat vars) = let val (decs, vars) = Vector.f val (decs'', else') = goBlock (ctx, bound, depth, else') in (decs @ decs' @ decs'', J.IfStat (exp, then', else')) end - | goStat (ctx, bound, depth, s as J.ReturnStat NONE) = ([], s) - | goStat (ctx, bound, depth, s as J.ReturnStat (SOME exp)) = let val (decs, exp) = goExp (ctx, bound, depth, exp) - in (decs, J.ReturnStat (SOME exp)) - end + | goStat (_, _, _, s as J.ReturnStat NONE) = ([], s) + | goStat (ctx, bound, depth, J.ReturnStat (SOME exp)) = let val (decs, exp) = goExp (ctx, bound, depth, exp) + in (decs, J.ReturnStat (SOME exp)) + end | goStat (ctx, bound, depth, J.TryCatchStat (try, vid, catch)) = let val (decs, try) = goBlock (ctx, bound, depth, try) val (decs', catch) = goBlock (ctx, J.IdSet.add (bound, J.UserDefinedId vid), depth, catch) in (decs @ decs', J.TryCatchStat (try, vid, catch)) @@ -187,12 +187,12 @@ and goStat (ctx, bound, depth, J.LetStat vars) = let val (decs, vars) = Vector.f ) ([], []) cases in (decs @ decs', J.SwitchStat (exp, cases)) end - | goStat (ctx, bound, depth, s as J.BreakStat _) = ([], s) - | goStat (ctx, bound, depth, s as J.ContinueStat _) = ([], s) + | goStat (_, _, _, s as J.BreakStat _) = ([], s) + | goStat (_, _, _, s as J.ContinueStat _) = ([], s) | goStat (ctx, bound, depth, J.DefaultExportStat exp) = let val (decs, exp) = goExp (ctx, bound, depth, exp) in (decs, J.DefaultExportStat exp) end - | goStat (ctx, bound, depth, s as J.NamedExportStat _) = ([], s) + | goStat (_, _, _, s as J.NamedExportStat _) = ([], s) and goBlock (ctx, bound, depth, stats) = let val bound' = collectLetConstBlock stats bound val (decs, ys) = Vector.foldr (fn (stat, (decs, ys)) => let val (decs', stat') = goStat (ctx, bound', depth, stat) diff --git a/src/list-util.sml b/src/list-util.sml index a30cc874..732bb8cc 100644 --- a/src/list-util.sml +++ b/src/list-util.sml @@ -18,9 +18,9 @@ in fun splitAt (xs, n) = splitAt' (xs, [], n) end -fun mapCont f [] cont = cont [] +fun mapCont _ [] cont = cont [] | mapCont f (x :: xs) cont = f (x, fn y => mapCont f xs (fn ys => cont (y :: ys))) -fun foldlCont f init [] cont = cont init +fun foldlCont _ init [] cont = cont init | foldlCont f init (x :: xs) cont = f (x, init, fn y => foldlCont f y xs cont) end; (* structure ListUtil *) diff --git a/src/lua-syntax.sml b/src/lua-syntax.sml index 9cc43dd9..3c7d3dc3 100644 --- a/src/lua-syntax.sml +++ b/src/lua-syntax.sml @@ -143,12 +143,12 @@ fun makeDoStat { loopLike : bool, body : Stat list } else body -fun freeVarsInExp (bound : IdSet.set, ConstExp _, acc : IdSet.set) = acc +fun freeVarsInExp (_ : IdSet.set, ConstExp _, acc : IdSet.set) = acc | freeVarsInExp (bound, VarExp v, acc) = if IdSet.member (bound, v) then acc else IdSet.add (acc, v) - | freeVarsInExp (bound, TableExp fields, acc) = Vector.foldl (fn ((k, x), acc) => freeVarsInExp (bound, x, acc)) acc fields + | freeVarsInExp (bound, TableExp fields, acc) = Vector.foldl (fn ((_, x), acc) => freeVarsInExp (bound, x, acc)) acc fields | freeVarsInExp (bound, CallExp (f, args), acc) = Vector.foldl (fn (x, acc) => freeVarsInExp (bound, x, acc)) (freeVarsInExp (bound, f, acc)) args | freeVarsInExp (bound, MethodExp (obj, _, args), acc) = Vector.foldl (fn (x, acc) => freeVarsInExp (bound, x, acc)) (freeVarsInExp (bound, obj, acc)) args | freeVarsInExp (bound, FunctionExp (params, body), acc) = freeVarsInBlock (Vector.foldl IdSet.add' bound params, body, acc) @@ -180,9 +180,9 @@ and freeVarsInStat (LocalStat (lhs, rhs), (bound, acc)) = let val acc = List.fol | freeVarsInStat (ReturnStat xs, (bound, acc)) = let val acc = Vector.foldl (fn (x, acc) => freeVarsInExp (bound, x, acc)) acc xs in (bound, acc) end - | freeVarsInStat (DoStat { loopLike, body }, (bound, acc)) = let val acc = freeVarsInBlock (bound, body, acc) - in (bound, acc) - end + | freeVarsInStat (DoStat { loopLike = _, body }, (bound, acc)) = let val acc = freeVarsInBlock (bound, body, acc) + in (bound, acc) + end | freeVarsInStat (GotoStat _, bound_acc) = bound_acc | freeVarsInStat (LabelStat _, bound_acc) = bound_acc and freeVarsInBlock (bound, block, acc) = #2 (Vector.foldl freeVarsInStat (bound, acc) block) @@ -322,7 +322,7 @@ fun findNextFragment [] = NONE | findNextFragment (Fragment "" :: fragments) = findNextFragment fragments | findNextFragment (Fragment s :: _) = SOME s | findNextFragment (_ :: fragments) = findNextFragment fragments -fun processIndent (revAcc, indent, []) = List.rev revAcc +fun processIndent (revAcc, _, []) = List.rev revAcc | processIndent (revAcc, indent, Fragment s :: fragments) = processIndent (s :: revAcc, indent, fragments) | processIndent (revAcc, indent, IncreaseIndent :: fragments) = processIndent (revAcc, indent + 2, fragments) | processIndent (revAcc, indent, DecreaseIndent :: fragments) = processIndent (revAcc, indent - 2, fragments) @@ -468,7 +468,7 @@ and doStat ([], acc) = acc doStat (rest, Indent :: Fragment "return" :: LineTerminator :: acc) else doStat (rest, Indent :: Fragment "return " :: commaSepV (Vector.map (#exp o doExp) exps) @ OptSemicolon :: acc) - | doStat (LuaSyntax.DoStat { loopLike, body } :: rest, acc) = doStat (rest, Indent :: Fragment "do" :: LineTerminator :: IncreaseIndent :: doBlock body @ DecreaseIndent :: Indent :: Fragment "end" :: LineTerminator :: acc) + | doStat (LuaSyntax.DoStat { loopLike = _, body } :: rest, acc) = doStat (rest, Indent :: Fragment "do" :: LineTerminator :: IncreaseIndent :: doBlock body @ DecreaseIndent :: Indent :: Fragment "end" :: LineTerminator :: acc) | doStat (LuaSyntax.GotoStat label :: rest, acc) = doStat (rest, Indent :: Fragment "goto " :: idToFragment label @ LineTerminator :: acc) | doStat (LuaSyntax.LabelStat label :: rest, acc) = doStat (rest, Indent :: Fragment "::" :: idToFragment label @ Fragment "::" :: LineTerminator :: acc) and doBlock stats = let val revStats = Vector.foldl (op ::) [] stats diff --git a/src/lua-transform.sml b/src/lua-transform.sml index 1e4874c5..67b17799 100644 --- a/src/lua-transform.sml +++ b/src/lua-transform.sml @@ -27,7 +27,7 @@ structure L = LuaSyntax fun hasInnerFunction (L.ConstExp _) = false | hasInnerFunction (L.VarExp _) = false - | hasInnerFunction (L.TableExp fields) = Vector.exists (fn (key, value) => hasInnerFunction value) fields + | hasInnerFunction (L.TableExp fields) = Vector.exists (fn (_, value) => hasInnerFunction value) fields | hasInnerFunction (L.CallExp (x, ys)) = hasInnerFunction x orelse Vector.exists hasInnerFunction ys | hasInnerFunction (L.MethodExp (x, _, ys)) = hasInnerFunction x orelse Vector.exists hasInnerFunction ys | hasInnerFunction (L.FunctionExp _) = true @@ -41,9 +41,9 @@ fun hasInnerFunctionStat (L.LocalStat (_, xs)) = List.exists hasInnerFunction xs | hasInnerFunctionStat (L.MethodStat (x, _, ys)) = hasInnerFunction x orelse Vector.exists hasInnerFunction ys | hasInnerFunctionStat (L.IfStat (x, then', else')) = hasInnerFunction x orelse hasInnerFunctionBlock then' orelse hasInnerFunctionBlock else' | hasInnerFunctionStat (L.ReturnStat xs) = Vector.exists hasInnerFunction xs - | hasInnerFunctionStat (L.DoStat { loopLike, body }) = hasInnerFunctionBlock body - | hasInnerFunctionStat (L.GotoStat label) = false - | hasInnerFunctionStat (L.LabelStat label) = false + | hasInnerFunctionStat (L.DoStat { loopLike = _, body }) = hasInnerFunctionBlock body + | hasInnerFunctionStat (L.GotoStat _) = false + | hasInnerFunctionStat (L.LabelStat _) = false and hasInnerFunctionBlock block = Vector.exists hasInnerFunctionStat block fun sizeOfStat (L.LocalStat (_, xs), acc) = acc + List.length xs @@ -52,9 +52,9 @@ fun sizeOfStat (L.LocalStat (_, xs), acc) = acc + List.length xs | sizeOfStat (L.MethodStat _, acc) = acc + 1 | sizeOfStat (L.IfStat (_, then', else'), acc) = sizeOfBlock (then', sizeOfBlock (else', acc + 1)) | sizeOfStat (L.ReturnStat xs, acc) = acc + Vector.length xs - | sizeOfStat (L.DoStat { loopLike, body }, acc) = sizeOfBlock (body, acc) - | sizeOfStat (L.GotoStat label, acc) = acc + 1 - | sizeOfStat (L.LabelStat label, acc) = acc + | sizeOfStat (L.DoStat { loopLike = _, body }, acc) = sizeOfBlock (body, acc) + | sizeOfStat (L.GotoStat _, acc) = acc + 1 + | sizeOfStat (L.LabelStat _, acc) = acc and sizeOfBlock (xs, acc) = Vector.foldl sizeOfStat acc xs fun freeVarsExp (_, L.ConstExp _) acc = acc @@ -62,7 +62,7 @@ fun freeVarsExp (_, L.ConstExp _) acc = acc acc else L.IdSet.add (acc, x) - | freeVarsExp (bound, L.TableExp fields) acc = Vector.foldl (fn ((key, x), acc) => freeVarsExp (bound, x) acc) acc fields + | freeVarsExp (bound, L.TableExp fields) acc = Vector.foldl (fn ((_, x), acc) => freeVarsExp (bound, x) acc) acc fields | freeVarsExp (bound, L.CallExp (x, ys)) acc = Vector.foldl (fn (y, acc) => freeVarsExp (bound, y) acc) (freeVarsExp (bound, x) acc) ys | freeVarsExp (bound, L.MethodExp (x, _, ys)) acc = Vector.foldl (fn (y, acc) => freeVarsExp (bound, y) acc) (freeVarsExp (bound, x) acc) ys | freeVarsExp (bound, L.FunctionExp (params, body)) acc = let val bound' = Vector.foldl (fn (id, bound) => L.IdSet.add (bound, id)) bound params @@ -93,16 +93,16 @@ and freeVarsStat (bound, L.LocalStat (vids, exps)) acc = let val acc = List.fold in (bound, acc) end | freeVarsStat (bound, L.ReturnStat xs) acc = (bound, Vector.foldl (fn (x, acc) => freeVarsExp (bound, x) acc) acc xs) - | freeVarsStat (bound, L.DoStat { loopLike, body }) acc = let val acc = freeVarsBlock (bound, body) acc - in (bound, acc) - end - | freeVarsStat (bound, L.GotoStat label) acc = (bound, acc) - | freeVarsStat (bound, L.LabelStat label) acc = (bound, acc) + | freeVarsStat (bound, L.DoStat { loopLike = _, body }) acc = let val acc = freeVarsBlock (bound, body) acc + in (bound, acc) + end + | freeVarsStat (bound, L.GotoStat _) acc = (bound, acc) + | freeVarsStat (bound, L.LabelStat _) acc = (bound, acc) and freeVarsBlock (bound, block) acc = let val (_, acc) = Vector.foldl (fn (stat, (bound, acc)) => freeVarsStat (bound, stat) acc) (bound, acc) block in acc end -fun substExp map (x as L.ConstExp _) = x +fun substExp _ (x as L.ConstExp _) = x | substExp map (x as L.VarExp id) = (case L.IdMap.find (map, id) of NONE => x | SOME y => y @@ -179,7 +179,7 @@ fun hoist targets ((stat as L.LocalStat (vars, exps)), (hoistedAcc, acc)) in (hoistedAcc', L.LocalStat (keep', []) :: L.AssignStat (List.map (fn (v, _) => L.VarExp (L.UserDefinedId v)) vars, exps) :: acc) end end - | hoist targets (stat, (hoistedAcc, acc)) = (hoistedAcc, stat :: acc) + | hoist _ (stat, (hoistedAcc, acc)) = (hoistedAcc, stat :: acc) fun doExp (e as L.ConstExp _) = e | doExp (e as L.VarExp _) = e | doExp (L.TableExp fields) = L.TableExp (Vector.map (fn (key, e) => (key, doExp e)) fields) @@ -209,18 +209,18 @@ and doBlock (numOuter, block) else goForward (rest, List.foldl (fn ((v, _), acc) => L.IdSet.add (acc, L.UserDefinedId v)) declared vars, numOuter, stat :: revStats) end - and goForward ([], declared : L.IdSet.set, numOuter : int, revStats) = List.rev revStats + and goForward ([], _ : L.IdSet.set, _ : int, revStats) = List.rev revStats | goForward ((live, L.LocalStat (vars, exps)) :: rest, declared, numOuter, revStats) = insertDo (vars, live, L.LocalStat (vars, List.map doExp exps), rest, declared, numOuter, revStats) - | goForward ((live, L.AssignStat (lhs, rhs)) :: rest, declared, numOuter, revStats) + | goForward ((_, L.AssignStat (lhs, rhs)) :: rest, declared, numOuter, revStats) = let val stat = L.AssignStat (List.map doExp lhs, List.map doExp rhs) in goForward (rest, declared, numOuter, stat :: revStats) end - | goForward ((live, L.CallStat (f, args)) :: rest, declared, numOuter, revStats) + | goForward ((_, L.CallStat (f, args)) :: rest, declared, numOuter, revStats) = let val stat = L.CallStat (doExp f, Vector.map doExp args) in goForward (rest, declared, numOuter, stat :: revStats) end - | goForward ((live, L.MethodStat (self, name, args)) :: rest, declared, numOuter, revStats) + | goForward ((_, L.MethodStat (self, name, args)) :: rest, declared, numOuter, revStats) = let val stat = L.MethodStat (doExp self, name, Vector.map doExp args) in goForward (rest, declared, numOuter, stat :: revStats) end @@ -228,16 +228,16 @@ and doBlock (numOuter, block) = let val n = numOuter + L.IdSet.numItems declared in insertDo ([], live, L.IfStat (doExp cond, doBlock (n, thenBlock), doBlock (n, elseBlock)), rest, declared, numOuter, revStats) end - | goForward ((live, L.ReturnStat exps) :: rest, declared, numOuter, revStats) + | goForward ((_, L.ReturnStat exps) :: rest, declared, numOuter, revStats) = let val stat = L.ReturnStat (Vector.map doExp exps) in goForward (rest, declared, numOuter, stat :: revStats) end - | goForward ((live, L.DoStat { loopLike, body }) :: rest, declared, numOuter, revStats) + | goForward ((_, L.DoStat { loopLike, body }) :: rest, declared, numOuter, revStats) = let val n = numOuter + L.IdSet.numItems declared val stat = L.DoStat { loopLike = loopLike, body = doBlock (n, body) } in goForward (rest, declared, numOuter, stat :: revStats) end - | goForward ((live, stat as L.GotoStat _) :: rest, declared, numOuter, revStats) = goForward (rest, declared, numOuter, stat :: revStats) + | goForward ((_, stat as L.GotoStat _) :: rest, declared, numOuter, revStats) = goForward (rest, declared, numOuter, stat :: revStats) | goForward ((live, stat as L.LabelStat _) :: rest, declared, numOuter, revStats) = let val dead = L.IdSet.difference (declared, live) val numDead = L.IdSet.numItems dead @@ -261,8 +261,8 @@ and doBlock (numOuter, block) end structure LuaJITFixup = struct val BODY_SIZE_THRESHOLD = 500 -fun doExp ctx (x as L.ConstExp _) = x - | doExp ctx (x as L.VarExp _) = x +fun doExp _ (x as L.ConstExp _) = x + | doExp _ (x as L.VarExp _) = x | doExp ctx (L.TableExp fields) = L.TableExp (Vector.map (fn (key, value) => (key, doExp ctx value)) fields) | doExp ctx (L.CallExp (x, ys)) = L.CallExp (doExp ctx x, Vector.map (doExp ctx) ys) | doExp ctx (L.MethodExp (x, name, ys)) = L.MethodExp (doExp ctx x, name, Vector.map (doExp ctx) ys) @@ -289,8 +289,8 @@ and doStat ctx (L.LocalStat (vars, xs)) = L.LocalStat (vars, List.map (doExp ctx | doStat ctx (L.IfStat (x, then', else')) = L.IfStat (doExp ctx x, doBlock ctx then', doBlock ctx else') | doStat ctx (L.ReturnStat xs) = L.ReturnStat (Vector.map (doExp ctx) xs) | doStat ctx (L.DoStat { loopLike, body }) = L.DoStat { loopLike = loopLike, body = doBlock ctx body } - | doStat ctx (stat as L.GotoStat _) = stat - | doStat ctx (stat as L.LabelStat _) = stat + | doStat _ (stat as L.GotoStat _) = stat + | doStat _ (stat as L.LabelStat _) = stat and doBlock ctx block = Vector.map (doStat ctx) block end structure ProcessUpvalue = struct @@ -303,8 +303,8 @@ val initialEnv : Env = { bound = mlinit_lua val initialEnvForLuaJIT : Env = { bound = mlinit_luajit , dynamic = mlinit_luajit } -fun doExp (ctx : Context) (env : Env) (exp as L.ConstExp ct) = ([], exp) - | doExp ctx env (exp as L.VarExp _) = ([], exp) +fun doExp (_ : Context) (_ : Env) (exp as L.ConstExp _) = ([], exp) + | doExp _ _ (exp as L.VarExp _) = ([], exp) | doExp ctx env (L.TableExp fields) = let val (decs, fields) = Vector.foldr (fn ((key, value), (decs, fields)) => let val (decs', value) = doExp ctx env value in (decs' @ decs, (key, value) :: fields) end) ([], []) fields @@ -331,7 +331,7 @@ fun doExp (ctx : Context) (env : Env) (exp as L.ConstExp ct) = ([], exp) val upvaluesMap = L.IdMap.filteri (fn (id, _) => L.IdSet.member (fv, id)) (#dynamic env) in if #maxUpvalue ctx < L.IdMap.numItems upvaluesMap then let val upvaluesList = L.IdMap.foldli (fn (id, attr, acc) => (id, attr) :: acc) [] upvaluesMap - val (constUpvalues, nonconstUpvalues) = List.partition (fn (id, L.CONST) => true | _ => false) upvaluesList + val (constUpvalues, nonconstUpvalues) = List.partition (fn (_, L.CONST) => true | _ => false) upvaluesList val n = List.length nonconstUpvalues val escapeList = if #maxUpvalue ctx - 1 < n then constUpvalues (* Need a better algorithm *) @@ -402,14 +402,14 @@ and doStat ctx env (L.LocalStat (vars, exps)) val (decs', args) = Vector.foldr (fn (x, (decs, xs)) => let val (decs', x) = doExp ctx env x in (decs' @ decs, x :: xs) end) ([], []) args - in (env, [L.MethodStat (self, method, vector args)]) + in (env, decs @ decs' @ [L.MethodStat (self, method, vector args)]) end | doStat ctx env (L.IfStat (cond, thenPart, elsePart)) = let val (decs, cond) = doExp ctx env cond val (dynamic1, thenPart) = doBlock ctx env thenPart val (dynamic2, elsePart) = doBlock ctx env elsePart val newEnv = { bound = #bound env - , dynamic = L.IdMap.mapi (fn (id, attr as L.CONST) => attr - | (id, attr as L.MUTABLE) => attr + , dynamic = L.IdMap.mapi (fn (_, attr as L.CONST) => attr + | (_, attr as L.MUTABLE) => attr | (id, attr as L.LATE_INIT) => (case L.IdMap.find (dynamic1, id) of SOME L.CONST => (case L.IdMap.find (dynamic2, id) of SOME L.CONST => L.CONST @@ -426,10 +426,10 @@ and doStat ctx env (L.LocalStat (vars, exps)) end) ([], []) results in (env, decs @ [L.ReturnStat (vector results)]) end - | doStat ctx env (L.DoStat { loopLike, body }) = let val (dynamic, block) = doBlock ctx env body + | doStat ctx env (L.DoStat { loopLike, body }) = let val (dynamic, body) = doBlock ctx env body val newEnv = { bound = #bound env - , dynamic = L.IdMap.mapi (fn (id, attr as L.CONST) => attr - | (id, attr as L.MUTABLE) => attr + , dynamic = L.IdMap.mapi (fn (_, attr as L.CONST) => attr + | (_, attr as L.MUTABLE) => attr | (id, attr as L.LATE_INIT) => (case L.IdMap.find (dynamic, id) of SOME L.CONST => L.CONST | _ => attr @@ -438,14 +438,14 @@ and doStat ctx env (L.LocalStat (vars, exps)) } in (newEnv, [L.DoStat { loopLike = loopLike, body = body }]) end - | doStat ctx env (stat as L.GotoStat _) = (env, [stat]) - | doStat ctx env (stat as L.LabelStat _) = (env, [stat]) -and doStats ctx env [] acc = (env, List.concat (List.rev acc)) + | doStat _ env (stat as L.GotoStat _) = (env, [stat]) + | doStat _ env (stat as L.LabelStat _) = (env, [stat]) +and doStats _ env [] acc = (env, List.concat (List.rev acc)) | doStats ctx env (stats as (L.AssignStat ([L.VarExp _], [L.FunctionExp (_, _)]) :: _)) acc = let val (env', defs, stats') = takeFunctionAssignments ctx env stats [] val (decs, inits, funcs) = List.foldr (fn ((v, f), (decs, inits, funcs)) => case doExp ctx env' f of ([L.LocalStat ([(u, L.CONST)], init)], f') => ((u, L.LATE_INIT) :: decs, L.AssignStat ([L.VarExp (L.UserDefinedId u)], init) :: inits, L.AssignStat ([L.VarExp v], [f']) :: funcs) - | ([], f') => (decs, inits, L.AssignStat ([L.VarExp v], [f]) :: funcs) + | ([], f') => (decs, inits, L.AssignStat ([L.VarExp v], [f']) :: funcs) | _ => raise Fail "ProcessUpvalue: unexpected transformation" ) ([], [], []) defs in case decs of @@ -455,7 +455,7 @@ and doStats ctx env [] acc = (env, List.concat (List.rev acc)) | doStats ctx env (stat :: stats) acc = let val (newEnv, stat') = doStat ctx env stat in doStats ctx newEnv stats (stat' :: acc) end -and takeFunctionAssignments ctx env (stats as (L.AssignStat ([L.VarExp v], [f as L.FunctionExp (params, body)]) :: stats')) revAcc +and takeFunctionAssignments ctx env (stats as (L.AssignStat ([L.VarExp v], [f as L.FunctionExp (_, _)]) :: stats')) revAcc = (case L.IdMap.find (#dynamic env, v) of SOME L.LATE_INIT => let val newEnv = { bound = #bound env , dynamic = L.IdMap.insert (#dynamic env, v, L.CONST) @@ -464,7 +464,7 @@ and takeFunctionAssignments ctx env (stats as (L.AssignStat ([L.VarExp v], [f as end | _ => (env, List.rev revAcc, stats) ) - | takeFunctionAssignments ctx env stats revAcc = (env, List.rev revAcc, stats) + | takeFunctionAssignments _ env stats revAcc = (env, List.rev revAcc, stats) and doBlock ctx env stats = let val (env', stats) = doStats ctx env (Vector.foldr (op ::) [] stats) [] val dynamic = #dynamic env' (* assumes no shadowing *) in (dynamic, vector stats) @@ -484,20 +484,20 @@ val initialEnvForLuaJIT : Env = { currentLocals = L.IdMap.numItems mlinit_luajit , valMap = TypedSyntax.VIdMap.empty } val LOCAL_LIMIT = 190 -fun doExp (ctx : Context) (env : Env) (exp as L.ConstExp ct) = exp - | doExp ctx env (exp as L.VarExp (L.PredefinedId _)) = exp - | doExp ctx env (exp as L.VarExp (L.UserDefinedId vid)) = (case TypedSyntax.VIdMap.find (#valMap env, vid) of - NONE => exp - | SOME (Plain vid) => L.VarExp (L.UserDefinedId vid) - | SOME (Index (locals, n)) => L.IndexExp (L.VarExp (L.UserDefinedId locals), L.ConstExp (L.Numeral (Int.toString n))) - ) +fun doExp (_ : Context) (_ : Env) (exp as L.ConstExp _) = exp + | doExp _ _ (exp as L.VarExp (L.PredefinedId _)) = exp + | doExp _ env (exp as L.VarExp (L.UserDefinedId vid)) = (case TypedSyntax.VIdMap.find (#valMap env, vid) of + NONE => exp + | SOME (Plain vid) => L.VarExp (L.UserDefinedId vid) + | SOME (Index (locals, n)) => L.IndexExp (L.VarExp (L.UserDefinedId locals), L.ConstExp (L.Numeral (Int.toString n))) + ) | doExp ctx env (L.TableExp fields) = L.TableExp (Vector.map (fn (key, value) => (key, doExp ctx env value)) fields) | doExp ctx env (L.CallExp (exp, args)) = L.CallExp (doExp ctx env exp, Vector.map (doExp ctx env) args) | doExp ctx env (L.MethodExp (self, method, args)) = L.MethodExp (doExp ctx env self, method, Vector.map (doExp ctx env) args) | doExp ctx env (L.FunctionExp (params, body)) = let val innerEnv = { currentLocals = Vector.length params , locals = NONE - , valMap = Vector.foldl (fn (L.PredefinedId param, valMap) => valMap + , valMap = Vector.foldl (fn (L.PredefinedId _, valMap) => valMap | (L.UserDefinedId vid, valMap) => TypedSyntax.VIdMap.insert (valMap, vid, Plain vid) ) (#valMap env) params } @@ -548,8 +548,8 @@ and doStat ctx env (L.LocalStat (vars, exps)) | NONE => (env, [L.DoStat { loopLike = true, body = doBlock ctx env body }]) ) | doStat ctx env (L.DoStat { loopLike = false, body }) = (env, [L.DoStat { loopLike = false, body = doBlock ctx env body }]) - | doStat ctx env (stat as L.GotoStat _) = (env, [stat]) - | doStat ctx env (stat as L.LabelStat _) = (env, [stat]) + | doStat _ env (stat as L.GotoStat _) = (env, [stat]) + | doStat _ env (stat as L.LabelStat _) = (env, [stat]) and doBlock ctx env stats = vector (List.concat (List.rev (#2 (Vector.foldl (fn (stat, (env, acc)) => let val (env, stat) = doStat ctx env stat in (env, stat :: acc) end diff --git a/src/lunarml.mlb b/src/lunarml.mlb index 88b44e70..94e04d20 100644 --- a/src/lunarml.mlb +++ b/src/lunarml.mlb @@ -2,10 +2,12 @@ $(SML_LIB)/basis/basis.mlb $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb ann "sequenceNonUnit warn" in +(* ann "warnUnused false" in *) compat/ord_set.sig compat/ord_map.sig compat/red-black-set-fn.sml compat/red-black-map-fn.sml +(* end *) list-util.sml vector-util.sml ../pluto/pluto.mlb diff --git a/src/main.sml b/src/main.sml index b734ac5c..235dfd84 100644 --- a/src/main.sml +++ b/src/main.sml @@ -5,7 +5,6 @@ structure Main : sig val main : string * string list -> unit end = struct -structure M = MLBSyntax; structure S = CommandLineSettings; datatype OutputMode = ExecutableMode | LibraryMode @@ -82,7 +81,7 @@ fun getTargetInfo (opts : options) : TargetInfo.target_info , wordSize = 32 } ) -fun optimizeCps (ctx : { nextVId : int ref, printTimings : bool }) cexp 0 = cexp +fun optimizeCps (_ : { nextVId : int ref, printTimings : bool }) cexp 0 = cexp | optimizeCps ctx cexp n = let val () = if #printTimings ctx then print ("[TIME] optimizeCps " ^ Int.toString n ^ "...") else @@ -100,7 +99,7 @@ fun optimizeCps (ctx : { nextVId : int ref, printTimings : bool }) cexp 0 = cexp else cexp end -fun emit (opts as { backend = BACKEND_LUA runtime, ... } : options) targetInfo fileName cont nextId cexp _ +fun emit (opts as { backend = BACKEND_LUA runtime, ... } : options) (_ (* targetInfo *)) fileName cont nextId cexp _ = let val timer = Timer.startCPUTimer () val base = OS.Path.base fileName val mlinit_lua = OS.Path.joinDirFile { dir = #libDir opts @@ -134,7 +133,7 @@ fun emit (opts as { backend = BACKEND_LUA runtime, ... } : options) targetInfo f () in () end - | emit (opts as { backend = BACKEND_LUAJIT, ... }) targetInfo fileName cont nextId cexp _ + | emit (opts as { backend = BACKEND_LUAJIT, ... }) _ fileName cont nextId cexp _ = let val timer = Timer.startCPUTimer () val base = OS.Path.base fileName val mlinit_lua = OS.Path.joinDirFile { dir = #libDir opts @@ -165,7 +164,7 @@ fun emit (opts as { backend = BACKEND_LUA runtime, ... } : options) targetInfo f () in () end - | emit (opts as { backend = BACKEND_JS style, ... }) targetInfo fileName cont nextId cexp export + | emit (opts as { backend = BACKEND_JS style, ... }) _ fileName cont nextId cexp export = let val timer = Timer.startCPUTimer () val contEscapeMap = CpsAnalyze.contEscape (cont, cexp) val base = OS.Path.base fileName @@ -224,7 +223,7 @@ fun doCompile (opts : options) fileName (f : MLBEval.Context -> MLBEval.Env * ML ] val targetInfo = getTargetInfo opts val errorCounter = Message.newCounter { errorTolerance = 10 } - fun printMessage { spans, domain, message, type_ } + fun printMessage { spans, domain = _, message, type_ } = let val t = case type_ of Message.WARNING => "warning: " | Message.ERROR => "error: " @@ -251,8 +250,8 @@ fun doCompile (opts : options) fileName (f : MLBEval.Context -> MLBEval.Env * ML , messageHandler = messageHandler } val timer = Timer.startCPUTimer () - val (env, { tynameset, toFEnv, fdecs, cache }) = f ctx - val toFContext = let fun printMessage { spans, domain, message, type_ } + val (env, { tynameset = _, toFEnv, fdecs, cache = _ }) = f ctx + val toFContext = let fun printMessage { spans, domain = _, message, type_ } = let val t = case type_ of Message.WARNING => "warning: " | Message.ERROR => "error: " @@ -281,7 +280,7 @@ fun doCompile (opts : options) fileName (f : MLBEval.Context -> MLBEval.Env * ML () val fexp = #doExp (DesugarPatternMatches.desugarPatternMatches toFContext) fexp val fexp = DecomposeValRec.doExp fexp - val (_, fdecs) = DeadCodeElimination.doExp fexp TypedSyntax.VIdSet.empty + val (_, fexp) = DeadCodeElimination.doExp fexp TypedSyntax.VIdSet.empty val optTime = Time.toMicroseconds (#usr (Timer.checkCPUTimer timer)) val () = if #dump opts = DUMP_FINAL then print (Printer.build (FPrinter.doExp 0 fexp) ^ "\n") @@ -326,7 +325,7 @@ fun doCompile (opts : options) fileName (f : MLBEval.Context -> MLBEval.Env * ML ( print ("internal error: " ^ message ^ "\n") ; OS.Process.exit OS.Process.failure ) - | DesugarPatternMatches.DesugarError (spans as ({start=p1 as {file=f1,line=l1,column=c1},end_=p2 as {file=f2,line=l2,column=c2}} :: _), message) => + | DesugarPatternMatches.DesugarError ({start = p1 as { file = f1, line = l1, column = c1 }, end_ = p2 as { file = f2, line = l2, column = c2 }} :: _, message) => ( if f1 = f2 then if p1 = p2 then print (f1 ^ ":" ^ Int.toString l1 ^ ":" ^ Int.toString c1 ^ ": " ^ message ^ "\n") @@ -351,8 +350,8 @@ fun handleInputFile opts [file] = if String.isSuffix ".sml" file then doCompile opts file (fn ctx => MLBEval.doMlbSource ctx MLBEval.emptyEnv file MLBEval.initialCode) else showMessageAndFail "Input filename must end with '.sml'\n" - | handleInputFile opts [] = showMessageAndFail "No input given.\n" - | handleInputFile opts _ = showMessageAndFail "Multiple input is not supported.\n" + | handleInputFile _ [] = showMessageAndFail "No input given.\n" + | handleInputFile _ _ = showMessageAndFail "Multiple input is not supported.\n" datatype 'a option_action = SIMPLE of 'a | WITH_ARG of string -> 'a datatype option_desc = SHORT of string @@ -386,7 +385,7 @@ fun testOption (_, []) = NONE end else NONE -fun parseOption (descs, []) = NONE +fun parseOption (_, []) = NONE | parseOption (descs, args) = let fun go [] = NONE | go (desc :: descs) = case testOption (desc, args) of SOME r => SOME r @@ -459,8 +458,8 @@ fun parseArgs (opts : options) args | SOME (OPT_TARGET_LUAJIT, args) => parseArgs (S.set.backend BACKEND_LUAJIT opts) args | SOME (OPT_TARGET_NODEJS, args) => parseArgs (S.set.backend (BACKEND_JS CodeGenJs.DIRECT_STYLE) opts) args | SOME (OPT_TARGET_NODEJS_CPS, args) => parseArgs (S.set.backend (BACKEND_JS CodeGenJs.CPS) opts) args - | SOME (OPT_HELP, args) => ( showHelp (); OS.Process.exit OS.Process.success ) - | SOME (OPT_VERSION, args) => ( showVersion (); OS.Process.exit OS.Process.success ) + | SOME (OPT_HELP, _) => ( showHelp (); OS.Process.exit OS.Process.success ) + | SOME (OPT_VERSION, _) => ( showVersion (); OS.Process.exit OS.Process.success ) | SOME (OPT_STOP, args) => handleInputFile opts args | SOME (OPT_DUMP, args) => parseArgs (S.set.dump DUMP_INITIAL opts) args | SOME (OPT_DUMP_FINAL, args) => parseArgs (S.set.dump DUMP_FINAL opts) args diff --git a/src/mlb-eval.sml b/src/mlb-eval.sml index c195877a..a4d53ae3 100644 --- a/src/mlb-eval.sml +++ b/src/mlb-eval.sml @@ -156,13 +156,13 @@ fun doDec (ctx : Context) langopt env (M.BasisDec binds) acc = let val (bas, acc ) (M.BasMap.empty, acc) binds in (envWithBasis bas, acc) end - | doDec ctx langopt env (M.OpenDec basids) acc = let val env' = List.foldl (fn (basid, newenv) => - case M.BasMap.find (#bas env, basid) of - SOME (MkEnv env) => mergeEnv (newenv, env) - | NONE => raise Fail ("undefined basis: " ^ basid) - ) emptyEnv basids - in (env', acc) - end + | doDec _ _ env (M.OpenDec basids) acc = let val env' = List.foldl (fn (basid, newenv) => + case M.BasMap.find (#bas env, basid) of + SOME (MkEnv env) => mergeEnv (newenv, env) + | NONE => raise Fail ("undefined basis: " ^ basid) + ) emptyEnv basids + in (env', acc) + end | doDec ctx langopt env (M.LocalDec (decs1, decs2)) acc = let val (env', acc) = doDecs ctx langopt env decs1 acc val (env'', acc) = doDecs ctx langopt (mergeEnv (env, env')) decs2 acc val typingEnv = { valMap = #valMap (#typing env'') @@ -175,48 +175,48 @@ fun doDec (ctx : Context) langopt env (M.BasisDec binds) acc = let val (bas, acc } in ({ bas = #bas env'', fixity = #fixity env'', typing = typingEnv }, acc) end - | doDec ctx langopt env (M.StructureDec binds) acc = let val strMap_fixity = #strMap (#idStatusMap (#fixity env)) - val strMap_fixity' = List.foldl (fn ((id1, id2), m) => - case Syntax.StrIdMap.find (strMap_fixity, id2) of - SOME value => Syntax.StrIdMap.insert (m, id1, value) - | NONE => raise Fail ("undefined structure: " ^ Syntax.print_StrId id2) - ) Syntax.StrIdMap.empty binds - val strMap_typing = #strMap (#typing env) - val strMap_typing' = List.foldl (fn ((id1, id2), m) => - case Syntax.StrIdMap.find (strMap_typing, id2) of - SOME value => Syntax.StrIdMap.insert (m, id1, value) - | NONE => raise Fail ("undefined structure: " ^ Syntax.print_StrId id2) - ) Syntax.StrIdMap.empty binds - in ({ bas = M.BasMap.empty, fixity = Fixity.envWithStrMap strMap_fixity', typing = Typing.envWithStrMap strMap_typing' }, acc) - end - | doDec ctx langopt env (M.SignatureDec binds) acc = let val sigMap_fixity = #sigMap (#fixity env) - val sigMap_fixity' = List.foldl (fn ((id1, id2), m) => - case Syntax.SigIdMap.find (sigMap_fixity, id2) of - SOME value => Syntax.SigIdMap.insert (m, id1, value) - | NONE => raise Fail ("undefined signature: " ^ Syntax.print_SigId id2) - ) Syntax.SigIdMap.empty binds - val sigMap_typing = #sigMap (#typing env) - val sigMap_typing' = List.foldl (fn ((id1, id2), m) => - case Syntax.SigIdMap.find (sigMap_typing, id2) of - SOME value => Syntax.SigIdMap.insert (m, id1, value) - | NONE => raise Fail ("undefined signature: " ^ Syntax.print_SigId id2) - ) Syntax.SigIdMap.empty binds - in ({ bas = M.BasMap.empty, fixity = Fixity.envWithSigMap sigMap_fixity, typing = Typing.envWithSigMap sigMap_typing' }, acc) - end - | doDec ctx langopt env (M.FunctorDec binds) acc = let val funMap_fixity = #funMap (#fixity env) - val funMap_fixity' = List.foldl (fn ((id1, id2), m) => - case Syntax.FunIdMap.find (funMap_fixity, id2) of - SOME value => Syntax.FunIdMap.insert (m, id1, value) - | NONE => raise Fail ("undefined functor: " ^ Syntax.print_FunId id2) - ) Syntax.FunIdMap.empty binds - val funMap_typing = #funMap (#typing env) - val funMap_typing' = List.foldl (fn ((id1, id2), m) => - case Syntax.FunIdMap.find (funMap_typing, id2) of - SOME value => Syntax.FunIdMap.insert (m, id1, value) - | NONE => raise Fail ("undefined functor: " ^ Syntax.print_FunId id2) - ) Syntax.FunIdMap.empty binds - in ({ bas = M.BasMap.empty, fixity = Fixity.envWithFunMap funMap_fixity, typing = Typing.envWithFunMap funMap_typing' }, acc) - end + | doDec _ _ env (M.StructureDec binds) acc = let val strMap_fixity = #strMap (#idStatusMap (#fixity env)) + val strMap_fixity' = List.foldl (fn ((id1, id2), m) => + case Syntax.StrIdMap.find (strMap_fixity, id2) of + SOME value => Syntax.StrIdMap.insert (m, id1, value) + | NONE => raise Fail ("undefined structure: " ^ Syntax.print_StrId id2) + ) Syntax.StrIdMap.empty binds + val strMap_typing = #strMap (#typing env) + val strMap_typing' = List.foldl (fn ((id1, id2), m) => + case Syntax.StrIdMap.find (strMap_typing, id2) of + SOME value => Syntax.StrIdMap.insert (m, id1, value) + | NONE => raise Fail ("undefined structure: " ^ Syntax.print_StrId id2) + ) Syntax.StrIdMap.empty binds + in ({ bas = M.BasMap.empty, fixity = Fixity.envWithStrMap strMap_fixity', typing = Typing.envWithStrMap strMap_typing' }, acc) + end + | doDec _ _ env (M.SignatureDec binds) acc = let val sigMap_fixity = #sigMap (#fixity env) + val sigMap_fixity' = List.foldl (fn ((id1, id2), m) => + case Syntax.SigIdMap.find (sigMap_fixity, id2) of + SOME value => Syntax.SigIdMap.insert (m, id1, value) + | NONE => raise Fail ("undefined signature: " ^ Syntax.print_SigId id2) + ) Syntax.SigIdMap.empty binds + val sigMap_typing = #sigMap (#typing env) + val sigMap_typing' = List.foldl (fn ((id1, id2), m) => + case Syntax.SigIdMap.find (sigMap_typing, id2) of + SOME value => Syntax.SigIdMap.insert (m, id1, value) + | NONE => raise Fail ("undefined signature: " ^ Syntax.print_SigId id2) + ) Syntax.SigIdMap.empty binds + in ({ bas = M.BasMap.empty, fixity = Fixity.envWithSigMap sigMap_fixity', typing = Typing.envWithSigMap sigMap_typing' }, acc) + end + | doDec _ _ env (M.FunctorDec binds) acc = let val funMap_fixity = #funMap (#fixity env) + val funMap_fixity' = List.foldl (fn ((id1, id2), m) => + case Syntax.FunIdMap.find (funMap_fixity, id2) of + SOME value => Syntax.FunIdMap.insert (m, id1, value) + | NONE => raise Fail ("undefined functor: " ^ Syntax.print_FunId id2) + ) Syntax.FunIdMap.empty binds + val funMap_typing = #funMap (#typing env) + val funMap_typing' = List.foldl (fn ((id1, id2), m) => + case Syntax.FunIdMap.find (funMap_typing, id2) of + SOME value => Syntax.FunIdMap.insert (m, id1, value) + | NONE => raise Fail ("undefined functor: " ^ Syntax.print_FunId id2) + ) Syntax.FunIdMap.empty binds + in ({ bas = M.BasMap.empty, fixity = Fixity.envWithFunMap funMap_fixity', typing = Typing.envWithFunMap funMap_typing' }, acc) + end | doDec ctx langopt env (M.PathDec path) acc = (case OS.Path.ext path of SOME "sml" => doSmlSource ctx langopt env path acc | SOME "fun" => doSmlSource ctx langopt env path acc @@ -227,17 +227,17 @@ fun doDec (ctx : Context) langopt env (M.BasisDec binds) acc = let val (bas, acc | doDec ctx langopt env (M.AnnotationDec (anns, decs)) acc = let val langopt = List.foldl (applyAnnotation (#messageHandler ctx)) langopt anns in doDecs ctx langopt env decs acc end - | doDec ctx langopt env M.PrimDec acc = ({ bas = M.BasMap.empty, fixity = InitialEnv.initialFixityEnv, typing = InitialEnv.initialEnv }, acc) - | doDec ctx langopt env M.PrimOverloadDec acc = ({ bas = M.BasMap.empty, fixity = Fixity.emptyEnv, typing = InitialEnv.primOverloadEnv }, acc) + | doDec _ _ _ M.PrimDec acc = ({ bas = M.BasMap.empty, fixity = InitialEnv.initialFixityEnv, typing = InitialEnv.initialEnv }, acc) + | doDec _ _ _ M.PrimOverloadDec acc = ({ bas = M.BasMap.empty, fixity = Fixity.emptyEnv, typing = InitialEnv.primOverloadEnv }, acc) and doDecs ctx langopt env decs acc = List.foldl (fn (dec, (newenv, acc)) => let val (env', acc) = doDec ctx langopt (mergeEnv (env, newenv)) dec acc in (mergeEnv (newenv, env'), acc) end ) (emptyEnv, acc) decs and doExp ctx langopt env (M.BasisExp decs) acc = doDecs ctx langopt env decs acc - | doExp ctx langopt env (M.BasIdExp basid) acc = (case M.BasMap.find (#bas env, basid) of - SOME (MkEnv env) => (env, acc) - | NONE => raise Fail ("undefined basis: " ^ basid) - ) + | doExp _ _ env (M.BasIdExp basid) acc = (case M.BasMap.find (#bas env, basid) of + SOME (MkEnv env) => (env, acc) + | NONE => raise Fail ("undefined basis: " ^ basid) + ) | doExp ctx langopt env (M.LetExp (decs, exp)) acc = let val (env', acc) = doDecs ctx langopt env decs acc in doExp ctx langopt (mergeEnv (env, env')) exp acc end @@ -252,28 +252,28 @@ and doSmlSource ctx langopt env path acc = let val path = OS.Path.mkAbsolute { p } in (newenv, { tynameset = tynameset, toFEnv = toFEnv, fdecs = #fdecs acc @ fdecs, cache = #cache acc }) end -and doMlbSource ctx env path acc = let val baseDir = #baseDir ctx - val path = OS.Path.mkAbsolute { path = M.evalPath (#pathMap ctx) path, relativeTo = baseDir } - in case M.StringMap.find (#cache acc, path) of - NONE => let val content = let val ins = TextIO.openIn path (* may raise Io *) - in TextIO.inputAll ins before TextIO.closeIn ins - end - in case MLBParser.P.runParser MLBParser.basfile MLBParser.initialState path (StringStream.fromString { file = path, content = content }) of - MLBParser.P.Ok (decs, _) => let val ctx' = { driverContext = #driverContext ctx - , baseDir = OS.Path.dir path - , pathMap = #pathMap ctx - , targetInfo = #targetInfo ctx - , defaultLanguageOptions = #defaultLanguageOptions ctx - , messageHandler = #messageHandler ctx - } - val (env', acc) = doDecs ctx' (#defaultLanguageOptions ctx) emptyEnv decs acc - val cache = M.StringMap.insert (#cache acc, path, env') - in (env', { tynameset = #tynameset acc, toFEnv = #toFEnv acc, fdecs = #fdecs acc, cache = cache }) - end - | MLBParser.P.ParseError e => ( TextIO.output (TextIO.stdErr, e ^ "\n") ; raise Message.Abort ) - end - | SOME e => (e, acc) - end +and doMlbSource ctx _ path acc = let val baseDir = #baseDir ctx + val path = OS.Path.mkAbsolute { path = M.evalPath (#pathMap ctx) path, relativeTo = baseDir } + in case M.StringMap.find (#cache acc, path) of + NONE => let val content = let val ins = TextIO.openIn path (* may raise Io *) + in TextIO.inputAll ins before TextIO.closeIn ins + end + in case MLBParser.P.runParser MLBParser.basfile MLBParser.initialState path (StringStream.fromString { file = path, content = content }) of + MLBParser.P.Ok (decs, _) => let val ctx' = { driverContext = #driverContext ctx + , baseDir = OS.Path.dir path + , pathMap = #pathMap ctx + , targetInfo = #targetInfo ctx + , defaultLanguageOptions = #defaultLanguageOptions ctx + , messageHandler = #messageHandler ctx + } + val (env', acc) = doDecs ctx' (#defaultLanguageOptions ctx) emptyEnv decs acc + val cache = M.StringMap.insert (#cache acc, path, env') + in (env', { tynameset = #tynameset acc, toFEnv = #toFEnv acc, fdecs = #fdecs acc, cache = cache }) + end + | MLBParser.P.ParseError e => ( TextIO.output (TextIO.stdErr, e ^ "\n") ; raise Message.Abort ) + end + | SOME e => (e, acc) + end datatype path_setting = PATH_MAP of string | PATH_VAR of string fun loadPathVar messageHandler (PATH_MAP file, pathMap) diff --git a/src/numeric.sml b/src/numeric.sml index 2de6ebc9..6e4b138e 100644 --- a/src/numeric.sml +++ b/src/numeric.sml @@ -156,10 +156,10 @@ fun notationToRatio (DecimalNotation { sign, intPart, fracPart, exponent }) (IntInf.<< (x, Word.fromInt e), 1) in (sign, n, d) end -fun checkExactness (format : float_format) (DecimalNotation _) = true (* OK *) - | checkExactness format (notation as HexadecimalNotation { sign, intPart, fracPart, exponent }) = let val { exact, value } = ratioToFloat format (notationToRatio notation) - in exact - end +fun checkExactness (_ : float_format) (DecimalNotation _) = true (* OK *) + | checkExactness format (notation as HexadecimalNotation _) = let val { exact, value = _ } = ratioToFloat format (notationToRatio notation) + in exact + end (* * Based on (FPP)^2 of [Dragon4], with modification to support subnormal @@ -227,7 +227,7 @@ fun positiveBinaryFloatToDecimal { precision, maxExponent } { value, exponent } end (* Assumption: #radix nominal_format = #radix target_format, #precision nominal_format <= #precision target_format, #maxExponent nominal_format <= #maxExponent target_format *) -fun toDecimal { nominal_format : float_format, target_format : float_format } (notation as DecimalNotation _) = SOME notation (* TODO: Convert to shorter representation if input is too long *) +fun toDecimal { nominal_format = _ : float_format, target_format = _ : float_format } (notation as DecimalNotation _) = SOME notation (* TODO: Convert to shorter representation if input is too long *) | toDecimal { nominal_format, target_format } (notation as HexadecimalNotation _) = let val { exact, value = x } = ratioToFloat nominal_format (notationToRatio notation) in case x of diff --git a/src/pattern-match.sml b/src/pattern-match.sml index c189a721..ce332cc2 100644 --- a/src/pattern-match.sml +++ b/src/pattern-match.sml @@ -28,38 +28,38 @@ datatype example = ANY | VALCON of Syntax.VId * example option | SOME_EXNCON | VECTOR of example list -fun toStringPrec (prec, ANY) = "_" - | toStringPrec (prec, SOME_INT) = "" - | toStringPrec (prec, SOME_WORD) = "" - | toStringPrec (prec, CHAR c) = "#\"" ^ Char.toString c ^ "\"" - | toStringPrec (prec, CHAR16 i) = if i <= 127 then - "#\"" ^ Char.toString (Char.chr i) ^ "\"" - else if i <= 0xff then - "#\"\\u00" ^ Int.fmt StringCvt.HEX i ^ "\"" - else if i <= 0xfff then - "#\"\\u0" ^ Int.fmt StringCvt.HEX i ^ "\"" - else - "#\"\\u" ^ Int.fmt StringCvt.HEX i ^ "\"" - | toStringPrec (prec, SOME_STRING) = "" - | toStringPrec (prec, SOME_STRING16) = "" - | toStringPrec (prec, RECORD fields) = let fun doTuple (i, [], acc) = SOME (List.rev acc) - | doTuple (i, (Syntax.NumericLabel j, x) :: fields, acc) = if i = j then - doTuple (i + 1, fields, x :: acc) - else - NONE - | doTuple (_, _, _) = NONE - in case doTuple (1, fields, []) of - SOME elems => "(" ^ String.concatWith ", " (List.map toString elems) ^ ")" - | NONE => "{" ^ String.concatWith ", " (List.map (fn (Syntax.IdentifierLabel name, x) => name ^ "=" ^ toString x - | (Syntax.NumericLabel i, x) => Int.toString i ^ "=" ^ toString x) fields) ^ "}" - end - | toStringPrec (prec, VALCON (vid, NONE)) = Syntax.getVIdName vid +fun toStringPrec (_, ANY) = "_" + | toStringPrec (_, SOME_INT) = "" + | toStringPrec (_, SOME_WORD) = "" + | toStringPrec (_, CHAR c) = "#\"" ^ Char.toString c ^ "\"" + | toStringPrec (_, CHAR16 i) = if i <= 127 then + "#\"" ^ Char.toString (Char.chr i) ^ "\"" + else if i <= 0xff then + "#\"\\u00" ^ Int.fmt StringCvt.HEX i ^ "\"" + else if i <= 0xfff then + "#\"\\u0" ^ Int.fmt StringCvt.HEX i ^ "\"" + else + "#\"\\u" ^ Int.fmt StringCvt.HEX i ^ "\"" + | toStringPrec (_, SOME_STRING) = "" + | toStringPrec (_, SOME_STRING16) = "" + | toStringPrec (_, RECORD fields) = let fun doTuple (_, [], acc) = SOME (List.rev acc) + | doTuple (i, (Syntax.NumericLabel j, x) :: fields, acc) = if i = j then + doTuple (i + 1, fields, x :: acc) + else + NONE + | doTuple (_, _, _) = NONE + in case doTuple (1, fields, []) of + SOME elems => "(" ^ String.concatWith ", " (List.map toString elems) ^ ")" + | NONE => "{" ^ String.concatWith ", " (List.map (fn (Syntax.IdentifierLabel name, x) => name ^ "=" ^ toString x + | (Syntax.NumericLabel i, x) => Int.toString i ^ "=" ^ toString x) fields) ^ "}" + end + | toStringPrec (_, VALCON (vid, NONE)) = Syntax.getVIdName vid | toStringPrec (prec, VALCON (vid, SOME payload)) = if prec >= 1 then "(" ^ Syntax.getVIdName vid ^ " " ^ toStringPrec (1, payload) ^ ")" else Syntax.getVIdName vid ^ " " ^ toStringPrec (1, payload) - | toStringPrec (prec, SOME_EXNCON) = "" - | toStringPrec (prec, VECTOR elems) = "#[" ^ String.concatWith "," (List.map toString elems) ^ "]" + | toStringPrec (_, SOME_EXNCON) = "" + | toStringPrec (_, VECTOR elems) = "#[" ^ String.concatWith "," (List.map toString elems) ^ "]" and toString x = toStringPrec (0, x) end structure CharSet = RedBlackSetFn (type ord_key = char; open Char) @@ -76,14 +76,14 @@ datatype set = VALCON of { seen : Syntax.VIdSet.set, all : Syntax.VIdSet.set, wi | RECORD of Syntax.LabelSet.set | VECTOR of IntRedBlackSet.set * int option | EMPTY -fun addValCon (VALCON { seen, all, withPayload }, { tag, allConstructors, constructorsWithPayload, representation }, hasPayload) +fun addValCon (VALCON { seen, all, withPayload }, { tag, allConstructors, constructorsWithPayload = _, representation = _ }, hasPayload) = let val tag = Syntax.MkVId tag in VALCON { seen = Syntax.VIdSet.add (seen, tag) , all = Syntax.VIdSet.union (all, allConstructors) , withPayload = if hasPayload then Syntax.VIdSet.add (withPayload, tag) else withPayload } end - | addValCon (EMPTY, { tag, allConstructors, constructorsWithPayload, representation }, hasPayload) + | addValCon (EMPTY, { tag, allConstructors, constructorsWithPayload, representation = _ }, _) = let val tag = Syntax.MkVId tag in VALCON { seen = Syntax.VIdSet.singleton tag , all = allConstructors @@ -119,7 +119,7 @@ fun addVector (VECTOR (seen, allAbove), n, false) = VECTOR (IntRedBlackSet.add ( | addVector (EMPTY, n, false) = VECTOR (IntRedBlackSet.singleton n, NONE) | addVector (EMPTY, n, true) = VECTOR (IntRedBlackSet.empty, SOME n) | addVector _ = raise Fail "invalid pattern" -fun isComplete (VALCON { seen, all, withPayload }) = Syntax.VIdSet.equal (seen, all) +(* fun isComplete (VALCON { seen, all, withPayload = _ }) = Syntax.VIdSet.equal (seen, all) | isComplete EXNCON = false | isComplete (INT _) = false (* TODO *) | isComplete (WORD _) = false (* TODO *) @@ -127,48 +127,48 @@ fun isComplete (VALCON { seen, all, withPayload }) = Syntax.VIdSet.equal (seen, | isComplete (CHAR16 seen) = IntRedBlackSet.numItems seen = 65536 | isComplete STRING = false | isComplete STRING16 = false - | isComplete (RECORD labels) = true - | isComplete (VECTOR (seen, NONE)) = false + | isComplete (RECORD _) = true + | isComplete (VECTOR (_, NONE)) = false | isComplete (VECTOR (seen, SOME n)) = let fun loop i = if i >= n then true else IntRedBlackSet.member (seen, i) andalso loop (i + 1) in loop 0 end - | isComplete EMPTY = false + | isComplete EMPTY = false *) end (* structure ConstructorSet *) fun collectConstructors (F.WildcardPat _, acc) = acc | collectConstructors (F.SConPat { scon, ... }, acc) = ConstructorSet.addSCon (acc, scon) | collectConstructors (F.VarPat _, acc) = acc - | collectConstructors (F.RecordPat { sourceSpan, fields, ellipsis, allFields }, acc) = ConstructorSet.addRecord (acc, allFields) - | collectConstructors (F.ValConPat { sourceSpan, info, payload }, acc) = ConstructorSet.addValCon (acc, info, Option.isSome payload) - | collectConstructors (F.ExnConPat { sourceSpan, tagPath, payload }, acc) = ConstructorSet.addExnCon acc + | collectConstructors (F.RecordPat { sourceSpan = _, fields = _, ellipsis = _, allFields }, acc) = ConstructorSet.addRecord (acc, allFields) + | collectConstructors (F.ValConPat { sourceSpan = _, info, payload }, acc) = ConstructorSet.addValCon (acc, info, Option.isSome payload) + | collectConstructors (F.ExnConPat { sourceSpan = _, tagPath = _, payload = _ }, acc) = ConstructorSet.addExnCon acc | collectConstructors (F.LayeredPat (_, _, _, innerPat), acc) = collectConstructors (innerPat, acc) - | collectConstructors (F.VectorPat (_, pats, ellipsis, ty), acc) = ConstructorSet.addVector (acc, Vector.length pats, ellipsis) + | collectConstructors (F.VectorPat (_, pats, ellipsis, _), acc) = ConstructorSet.addVector (acc, Vector.length pats, ellipsis) fun specializeValCon (con, hasPayload) = let fun goPat (F.WildcardPat span, ps) = if hasPayload then [F.WildcardPat span :: ps] else [ps] - | goPat (F.SConPat _, ps) = [] (* should not occur *) + | goPat (F.SConPat _, _) = [] (* should not occur *) | goPat (F.VarPat (span, _, _), ps) = if hasPayload then [F.WildcardPat span :: ps] else [ps] - | goPat (F.RecordPat _, ps) = [] (* should not occur *) - | goPat (F.ValConPat { sourceSpan, info = { tag, ... }, payload = NONE }, ps) + | goPat (F.RecordPat _, _) = [] (* should not occur *) + | goPat (F.ValConPat { sourceSpan = _, info = { tag, ... }, payload = NONE }, ps) = if Syntax.MkVId tag = con andalso not hasPayload then [ps] else [] - | goPat (F.ValConPat { sourceSpan, info = { tag, ... }, payload = SOME (_, pat) }, ps) + | goPat (F.ValConPat { sourceSpan = _, info = { tag, ... }, payload = SOME (_, pat) }, ps) = if Syntax.MkVId tag = con andalso hasPayload then [pat :: ps] else [] - | goPat (F.ExnConPat _, ps) = [] (* should not occur *) + | goPat (F.ExnConPat _, _) = [] (* should not occur *) | goPat (F.LayeredPat (_, _, _, pat), ps) = goPat (pat, ps) - | goPat (F.VectorPat _, ps) = [] (* should not occur *) + | goPat (F.VectorPat _, _) = [] (* should not occur *) fun goMatrix [] = [] | goMatrix ((p :: ps) :: rest) = goPat (p, ps) @ goMatrix rest | goMatrix _ = raise Fail "invalid pattern matrix" @@ -182,42 +182,42 @@ fun specializeExnCon (tag, hasPayload) [F.WildcardPat span :: ps] else [ps] - | goPat (F.SConPat _, ps) = [] (* should not occur *) + | goPat (F.SConPat _, _) = [] (* should not occur *) | goPat (F.VarPat (span, _, _), ps) = if hasPayload then [F.WildcardPat span :: ps] else [ps] - | goPat (F.RecordPat _, ps) = [] (* should not occur *) - | goPat (F.ValConPat _, ps) = [] (* should not occur *) - | goPat (F.ExnConPat { sourceSpan, tagPath, payload = NONE }, ps) + | goPat (F.RecordPat _, _) = [] (* should not occur *) + | goPat (F.ValConPat _, _) = [] (* should not occur *) + | goPat (F.ExnConPat { sourceSpan = _, tagPath, payload = NONE }, ps) = if sameExp (tag, tagPath) andalso not hasPayload then [ps] else [] - | goPat (F.ExnConPat { sourceSpan, tagPath, payload = SOME (_, pat) }, ps) + | goPat (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (_, pat) }, ps) = if sameExp (tag, tagPath) andalso hasPayload then [pat :: ps] else [] | goPat (F.LayeredPat (_, _, _, pat), ps) = goPat (pat, ps) - | goPat (F.VectorPat _, ps) = [] (* should not occur *) + | goPat (F.VectorPat _, _) = [] (* should not occur *) fun goMatrix [] = [] | goMatrix ((p :: ps) :: rest) = goPat (p, ps) @ goMatrix rest | goMatrix _ = raise Fail "invalid pattern matrix" in goMatrix end fun specializeSCon scon - = let fun goPat (F.WildcardPat span, ps) = [ps] + = let fun goPat (F.WildcardPat _, ps) = [ps] | goPat (F.SConPat { scon = scon', ... }, ps) = if scon' = scon then [ps] else [] - | goPat (F.VarPat (span, _, _), ps) = [ps] - | goPat (F.RecordPat _, ps) = [] (* should not occur *) - | goPat (F.ValConPat _, ps) = [] (* should not occur *) - | goPat (F.ExnConPat _, ps) = [] (* should not occur *) + | goPat (F.VarPat (_, _, _), ps) = [ps] + | goPat (F.RecordPat _, _) = [] (* should not occur *) + | goPat (F.ValConPat _, _) = [] (* should not occur *) + | goPat (F.ExnConPat _, _) = [] (* should not occur *) | goPat (F.LayeredPat (_, _, _, pat), ps) = goPat (pat, ps) - | goPat (F.VectorPat _, ps) = [] (* should not occur *) + | goPat (F.VectorPat _, _) = [] (* should not occur *) fun goMatrix [] = [] | goMatrix ((p :: ps) :: rest) = goPat (p, ps) @ goMatrix rest | goMatrix _ = raise Fail "invalid pattern matrix" @@ -234,23 +234,23 @@ fun getFieldFromList (label, fields, ellipsis) loop rest in loop fields end -and getFieldFromPat (label, pat as F.WildcardPat span) = pat - | getFieldFromPat (label, F.VarPat (span, _, _)) = F.WildcardPat span - | getFieldFromPat (label, F.RecordPat { sourceSpan, fields, ellipsis, allFields }) = getFieldFromList (label, fields, ellipsis) +and getFieldFromPat (_, pat as F.WildcardPat _) = pat + | getFieldFromPat (_, F.VarPat (span, _, _)) = F.WildcardPat span + | getFieldFromPat (label, F.RecordPat { sourceSpan = _, fields, ellipsis, allFields = _ }) = getFieldFromList (label, fields, ellipsis) | getFieldFromPat (label, F.LayeredPat (_, _, _, pat)) = getFieldFromPat (label, pat) | getFieldFromPat _ = raise Fail "invalid pattern: record" fun specializeRecord labels = let fun goPat (F.WildcardPat span, ps) = [List.tabulate (Syntax.LabelSet.numItems labels, fn _ => F.WildcardPat span) @ ps] - | goPat (F.SConPat _, ps) = [] (* should not occur *) + | goPat (F.SConPat _, _) = [] (* should not occur *) | goPat (F.VarPat (span, _, _), ps) = [List.tabulate (Syntax.LabelSet.numItems labels, fn _ => F.WildcardPat span) @ ps] - | goPat (F.RecordPat { sourceSpan, fields, ellipsis, allFields }, ps) = if Syntax.LabelSet.equal (labels, allFields) then - [Syntax.LabelSet.foldr (fn (label, ps) => getFieldFromList (label, fields, ellipsis) :: ps) ps labels] - else - [] - | goPat (F.ValConPat _, ps) = [] (* should not occur *) - | goPat (F.ExnConPat _, ps) = [] (* should not occur *) + | goPat (F.RecordPat { sourceSpan = _, fields, ellipsis, allFields }, ps) = if Syntax.LabelSet.equal (labels, allFields) then + [Syntax.LabelSet.foldr (fn (label, ps) => getFieldFromList (label, fields, ellipsis) :: ps) ps labels] + else + [] + | goPat (F.ValConPat _, _) = [] (* should not occur *) + | goPat (F.ExnConPat _, _) = [] (* should not occur *) | goPat (F.LayeredPat (_, _, _, pat), ps) = goPat (pat, ps) - | goPat (F.VectorPat _, ps) = [] (* should not occur *) + | goPat (F.VectorPat _, _) = [] (* should not occur *) fun goMatrix [] = [] | goMatrix ((p :: ps) :: rest) = goPat (p, ps) @ goMatrix rest | goMatrix _ = raise Fail "invalid pattern matrix" @@ -258,11 +258,11 @@ fun specializeRecord labels end fun specializeVector n = let fun goPat (F.WildcardPat span, ps) = [List.tabulate (n, fn _ => F.WildcardPat span) @ ps] - | goPat (F.SConPat _, ps) = [] (* should not occur *) + | goPat (F.SConPat _, _) = [] (* should not occur *) | goPat (F.VarPat (span, _, _), ps) = [List.tabulate (n, fn _ => F.WildcardPat span) @ ps] - | goPat (F.RecordPat _, ps) = [] (* should not occur *) - | goPat (F.ValConPat _, ps) = [] (* should not occur *) - | goPat (F.ExnConPat _, ps) = [] (* should not occur *) + | goPat (F.RecordPat _, _) = [] (* should not occur *) + | goPat (F.ValConPat _, _) = [] (* should not occur *) + | goPat (F.ExnConPat _, _) = [] (* should not occur *) | goPat (F.LayeredPat (_, _, _, pat), ps) = goPat (pat, ps) | goPat (F.VectorPat (span, pats, ellipsis, _), ps) = let val m = Vector.length pats @@ -386,7 +386,7 @@ fun useful ([], _) = true | useful (matrix, q :: qs) = let fun wildcard () = let val firsts = List.map List.hd matrix val constructors = List.foldl collectConstructors ConstructorSet.EMPTY firsts in case isComplete constructors of - COMPLETE specializers => List.exists (fn (specialize, arity, construct) => useful (specialize matrix, List.tabulate (arity, fn _ => F.WildcardPat SourcePos.nullSpan) @ qs)) specializers + COMPLETE specializers => List.exists (fn (specialize, arity, _) => useful (specialize matrix, List.tabulate (arity, fn _ => F.WildcardPat SourcePos.nullSpan) @ qs)) specializers | INCOMPLETE _ => useful (defaultMatrix matrix, qs) end fun goPat (F.WildcardPat _) = wildcard () @@ -394,11 +394,11 @@ fun useful ([], _) = true | goPat (F.VarPat _) = wildcard () | goPat (F.RecordPat { sourceSpan = _, fields, ellipsis, allFields }) = useful (specializeRecord allFields matrix, Syntax.LabelSet.foldr (fn (label, qs) => getFieldFromList (label, fields, ellipsis) :: qs) qs allFields) | goPat (F.ValConPat { sourceSpan = _, info = { tag, ... }, payload = NONE }) = useful (specializeValCon (Syntax.MkVId tag, false) matrix, qs) - | goPat (F.ValConPat { sourceSpan = _, info = { tag, ... }, payload = SOME (ty, innerPat) }) = useful (specializeValCon (Syntax.MkVId tag, true) matrix, innerPat :: qs) + | goPat (F.ValConPat { sourceSpan = _, info = { tag, ... }, payload = SOME (_, innerPat) }) = useful (specializeValCon (Syntax.MkVId tag, true) matrix, innerPat :: qs) | goPat (F.ExnConPat { sourceSpan = _, tagPath, payload = NONE }) = useful (specializeExnCon (tagPath, false) matrix, qs) - | goPat (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (ty, innerPat) }) = useful (specializeExnCon (tagPath, true) matrix, innerPat :: qs) + | goPat (F.ExnConPat { sourceSpan = _, tagPath, payload = SOME (_, innerPat) }) = useful (specializeExnCon (tagPath, true) matrix, innerPat :: qs) | goPat (F.LayeredPat (_, _, _, pat)) = goPat pat - | goPat (F.VectorPat (_, pats, ellipsis, _)) = useful (specializeVector (Vector.length pats) matrix, Vector.foldr (op ::) qs pats) + | goPat (F.VectorPat (_, pats, _, _)) = useful (specializeVector (Vector.length pats) matrix, Vector.foldr (op ::) qs pats) in goPat q end datatype message_type = WARNING | ERROR @@ -415,7 +415,7 @@ fun checkExhaustiveness (ctx, span, matches, mtype) | SOME _ => raise Fail "invalid number of examples" end fun checkRedundancy (ctx, matches, mtype) - = let val matrix = List.map (fn (pat, _) => [pat]) matches + = let (* val matrix = List.map (fn (pat, _) => [pat]) matches *) fun go ([], _) = () | go ((pat, _) :: matches, seen) = if useful (seen, [pat]) then (* the order of matrix (seen) is reversed, but should not affect usefulness *) go (matches, [pat] :: seen) @@ -424,13 +424,13 @@ fun checkRedundancy (ctx, matches, mtype) in go (matches, []) end fun goExp (ctx, F.PrimExp (_, _, exps)) = List.app (fn x => goExp (ctx, x)) exps - | goExp (ctx, F.VarExp _) = () + | goExp (_, F.VarExp _) = () | goExp (ctx, F.RecordExp fields) = List.app (fn (_, exp) => goExp (ctx, exp)) fields | goExp (ctx, F.LetExp (decs, exp)) = (List.app (fn dec => goDec (ctx, dec)) decs; goExp (ctx, exp)) | goExp (ctx, F.AppExp (x, y)) = (goExp (ctx, x); goExp (ctx, y)) - | goExp (ctx, F.HandleExp { body, exnName, handler }) = (goExp (ctx, body); goExp (ctx, handler)) + | goExp (ctx, F.HandleExp { body, exnName = _, handler }) = (goExp (ctx, body); goExp (ctx, handler)) | goExp (ctx, F.IfThenElseExp (x, y, z)) = (goExp (ctx, x); goExp (ctx, y); goExp (ctx, z)) - | goExp (ctx, F.CaseExp { sourceSpan, subjectExp, subjectTy, matches, matchType, resultTy }) + | goExp (ctx, F.CaseExp { sourceSpan, subjectExp, subjectTy = _, matches, matchType, resultTy = _ }) = ( goExp (ctx, subjectExp) ; List.app (fn (_, exp) => goExp (ctx, exp)) matches ; let val opt = case matchType of @@ -452,20 +452,20 @@ fun goExp (ctx, F.PrimExp (_, _, exps)) = List.app (fn x => goExp (ctx, x)) exps | LanguageOptions.ERROR => checkRedundancy (ctx, matches, ERROR) end ) - | goExp (ctx, F.FnExp (vid, ty, body)) = goExp (ctx, body) - | goExp (ctx, F.ProjectionExp { label, record, fieldTypes }) = goExp (ctx, record) + | goExp (ctx, F.FnExp (_, _, body)) = goExp (ctx, body) + | goExp (ctx, F.ProjectionExp { label = _, record, fieldTypes = _ }) = goExp (ctx, record) | goExp (ctx, F.TyAbsExp (_, _, exp)) = goExp (ctx, exp) | goExp (ctx, F.TyAppExp (exp, _)) = goExp (ctx, exp) - | goExp (ctx, F.PackExp { payloadTy, exp, packageTy }) = goExp (ctx, exp) - | goExp (ctx, F.BogusExp _) = () - | goExp (ctx, F.ExitProgram) = () + | goExp (ctx, F.PackExp { payloadTy = _, exp, packageTy = _ }) = goExp (ctx, exp) + | goExp (_, F.BogusExp _) = () + | goExp (_, F.ExitProgram) = () | goExp (ctx, F.ExportValue exp) = goExp (ctx, exp) | goExp (ctx, F.ExportModule fields) = Vector.app (fn (_, exp) => goExp (ctx, exp)) fields and goDec (ctx, F.ValDec (_, _, exp)) = goExp (ctx, exp) | goDec (ctx, F.RecValDec decs) = List.app (fn (_, _, exp) => goExp (ctx, exp)) decs | goDec (ctx, F.UnpackDec (_, _, _, _, exp)) = goExp (ctx, exp) | goDec (ctx, F.IgnoreDec exp) = goExp (ctx, exp) - | goDec (ctx, F.DatatypeDec _) = () - | goDec (ctx, F.ExceptionDec _) = () - | goDec (ctx, F.ESImportDec _) = () + | goDec (_, F.DatatypeDec _) = () + | goDec (_, F.ExceptionDec _) = () + | goDec (_, F.ESImportDec _) = () end; (* structure CheckPatternMatch *) diff --git a/src/postparsing.sml b/src/postparsing.sml index 7f924342..c6ab26b1 100644 --- a/src/postparsing.sml +++ b/src/postparsing.sml @@ -174,13 +174,13 @@ fun ('a, 'op) resolveFixity (ctx, f) : ('op, 'a) InfixList -> 'a and goRightAssoc : int * SourcePos.span * ('a * SourcePos.span * 'op) list * ('op, 'a) InfixList -> ('op, 'a) InfixList *) fun go (Leaf x) = x - | go (t as Tree (_, assoc, span, _, rest)) = let val p0 = case assoc of - Syntax.LeftAssoc p0 => p0 - | Syntax.RightAssoc p0 => p0 - val prec = maxPrec (p0, rest) - in go (goPrec (prec, t)) - end - and goPrec (p, Leaf x) = Leaf x + | go (t as Tree (_, assoc, _, _, rest)) = let val p0 = case assoc of + Syntax.LeftAssoc p0 => p0 + | Syntax.RightAssoc p0 => p0 + val prec = maxPrec (p0, rest) + in go (goPrec (prec, t)) + end + and goPrec (_, Leaf x) = Leaf x | goPrec (p, Tree (x, assoc as Syntax.LeftAssoc q, span, op_, rest)) = if p = q then goLeftAssoc (p, x, span, op_, rest) @@ -191,7 +191,7 @@ fun ('a, 'op) resolveFixity (ctx, f) : ('op, 'a) InfixList -> 'a goRightAssoc (p, span, [(x, span, op_)], rest) else (* p > q *) Tree (x, assoc, span, op_, goPrec (p, rest)) - and goLeftAssoc (p, x, span, op_, Leaf y) = Leaf (f (x, span, op_, y)) + and goLeftAssoc (_, x, span, op_, Leaf y) = Leaf (f (x, span, op_, y)) | goLeftAssoc (p, x, span1, op_, Tree (y, assoc as Syntax.LeftAssoc q, span2, op', rest)) = if p = q then goLeftAssoc (p, f (x, span1, op_, y), span2, op', rest) @@ -202,7 +202,7 @@ fun ('a, 'op) resolveFixity (ctx, f) : ('op, 'a) InfixList -> 'a emitError (ctx, [span1, span2], "you cannot mix left-associative operators and right-associative operators of same precedence") else (* p > q *) Tree (f (x, span1, op_, y), assoc, span2, op', goPrec (p, rest)) - and goRightAssoc (p, _, zs, Leaf y) = Leaf (List.foldl (fn ((x, span, op'), y) => f (x, span, op', y)) y zs) + and goRightAssoc (_, _, zs, Leaf y) = Leaf (List.foldl (fn ((x, span, op'), y) => f (x, span, op', y)) y zs) | goRightAssoc (p, span1, zs, Tree (y, assoc as Syntax.LeftAssoc q, span2, op', rest)) = if p = q then emitError (ctx, [span1, span2], "you cannot mix left-associative operators and right-associative operators of same precedence") @@ -217,22 +217,22 @@ fun ('a, 'op) resolveFixity (ctx, f) : ('op, 'a) InfixList -> 'a end (* let open Fixity in resolveFixity (fn (a,f,b) => f(a,b)) (Tree(3,Syntax.LeftAssoc 5,op +,Tree(2,Syntax.LeftAssoc 6,op *,Leaf 7))) end; should yield 17 *) -fun doOptBar (ctx : Context, Syntax.NO_BAR) = () +fun doOptBar (_ : Context, Syntax.NO_BAR) = () | doOptBar (ctx, Syntax.HAS_BAR span) = if #allowOptBar (#languageOptions ctx) then () else emitNonfatalError (ctx, [span], "extra bar") (*: val doPat : Context * Env * UnfixedSyntax.Pat -> Syntax.Pat *) -fun doPat(ctx, env : Env, UnfixedSyntax.WildcardPat span) = Syntax.WildcardPat span - | doPat(ctx, env, UnfixedSyntax.SConPat(span, scon)) = Syntax.SConPat(span, scon) +fun doPat (_, _ : Env, UnfixedSyntax.WildcardPat span) = Syntax.WildcardPat span + | doPat (_, _, UnfixedSyntax.SConPat (span, scon)) = Syntax.SConPat (span, scon) | doPat(ctx, env, UnfixedSyntax.InfixOrVIdPat(span, vid)) = (case getFixityStatus(env, vid) of Syntax.Nonfix => ConOrVarPat(env, span, vid) | _ => emitError(ctx, [span], "infix operator used in non-infix position") ) - | doPat (ctx, env, UnfixedSyntax.InfixPat (span, _)) = emitError(ctx, [span], "infix operator used in non-infix position C") - | doPat(ctx, env, UnfixedSyntax.NonInfixVIdPat(span, Syntax.MkQualified([], vid))) = ConOrVarPat(env, span, vid) - | doPat(ctx, env, UnfixedSyntax.NonInfixVIdPat(span, longvid)) = Syntax.ConPat(span, longvid, NONE) (* TODO: Check idstatus? *) + | doPat (ctx, _, UnfixedSyntax.InfixPat (span, _)) = emitError (ctx, [span], "infix operator used in non-infix position C") + | doPat (_, env, UnfixedSyntax.NonInfixVIdPat (span, Syntax.MkQualified ([], vid))) = ConOrVarPat (env, span, vid) + | doPat (_, _, UnfixedSyntax.NonInfixVIdPat (span, longvid)) = Syntax.ConPat (span, longvid, NONE) (* TODO: Check idstatus? *) | doPat(ctx, env, UnfixedSyntax.RecordPat (span, items)) = let val (fields, ellipsis) = List.foldr (fn (UnfixedSyntax.Field (label, pat, _), (fields, ellipsis)) => ((label, doPat (ctx, env, pat)) :: fields, ellipsis) | (UnfixedSyntax.Ellipsis pat, (fields, NONE)) => (fields, SOME (doPat (ctx, env, pat))) @@ -247,7 +247,7 @@ fun doPat(ctx, env : Env, UnfixedSyntax.WildcardPat span) = Syntax.WildcardPat s Syntax.Nonfix => doInfix(Syntax.ConPat(SourcePos.mergeSpan(span1, span2), Syntax.MkLongVId([], vid), SOME(ConOrVarPat(env, span2, vid'))), pats) | Syntax.Infix assoc => Tree(ConOrVarPat(env, span1, vid), assoc, span2, Syntax.MkQualified ([], vid'), doPrefix(pats)) ) - | Syntax.Infix assoc => emitError(ctx, [span1], "infix operator used in prefix position") + | Syntax.Infix _ => emitError (ctx, [span1], "infix operator used in prefix position") ) | doPrefix (atpat :: UnfixedSyntax.InfixPat (span2, longvid as Syntax.MkQualified (_, shortvid)) :: pats) = let val assoc = getDottedFixityStatus (env, shortvid) @@ -313,13 +313,13 @@ and doDec : Context * Env * UnfixedSyntax.Dec -> Env * Syntax.Dec list and doDecs : Context * Env * UnfixedSyntax.Dec list -> Env * Syntax.Dec list and doValBind : Context * Env * UnfixedSyntax.ValBind -> Syntax.ValBind *) -fun doExp(ctx, env, UnfixedSyntax.SConExp(span, scon)) = Syntax.SConExp(span, scon) +fun doExp (_, _, UnfixedSyntax.SConExp (span, scon)) = Syntax.SConExp (span, scon) | doExp(ctx, env, UnfixedSyntax.InfixOrVIdExp(span, vid)) = (case getFixityStatus(env, vid) of Syntax.Nonfix => Syntax.VarExp(span, Syntax.MkLongVId([], vid)) | _ => emitError(ctx, [span], "infix operaor used in non-infix position") ) - | doExp (ctx, env, UnfixedSyntax.InfixExp (span, _)) = emitError (ctx, [span], "infix operator used in non-infix position") - | doExp(ctx, env, UnfixedSyntax.NonInfixVIdExp(span, longvid)) = Syntax.VarExp(span, longvid) + | doExp (ctx, _, UnfixedSyntax.InfixExp (span, _)) = emitError (ctx, [span], "infix operator used in non-infix position") + | doExp (_, _, UnfixedSyntax.NonInfixVIdExp (span, longvid)) = Syntax.VarExp (span, longvid) | doExp(ctx, env, UnfixedSyntax.RecordExp (span, items)) = let val (fields1, ellipsis, fields2) = List.foldr (fn (UnfixedSyntax.Field (label, exp, pun), (fields1, ellipsis as SOME _, fields2)) => ( if pun andalso not (#allowRecordPunExps (#languageOptions ctx)) then emitNonfatalError (ctx, [span], "record pun in expression is not allowed") @@ -334,7 +334,7 @@ fun doExp(ctx, env, UnfixedSyntax.SConExp(span, scon)) = Syntax.SConExp(span, sc ; (fields1, ellipsis, (label, doExp (ctx, env, exp)) :: fields2) ) | (UnfixedSyntax.Ellipsis exp, (fields1, NONE, fields2)) => (fields1, SOME (doExp (ctx, env, exp)), fields2) - | (UnfixedSyntax.Ellipsis exp, (fields1, SOME _, fields2)) => emitError (ctx, [span], "multiple ellipses in a record expression") + | (UnfixedSyntax.Ellipsis _, (_, SOME _, _)) => emitError (ctx, [span], "multiple ellipses in a record expression") ) ([], NONE, []) items in case ellipsis of NONE => Syntax.RecordExp (span, fields2, NONE) @@ -358,7 +358,7 @@ fun doExp(ctx, env, UnfixedSyntax.SConExp(span, scon)) = Syntax.SConExp(span, sc () ; (label, doExp (ctx, env, exp)) ) - | UnfixedSyntax.Ellipsis exp => emitError (ctx, [span], "invalid record update") + | UnfixedSyntax.Ellipsis _ => emitError (ctx, [span], "invalid record update") ) update val patrow = List.map (fn (label, _) => (label, Syntax.WildcardPat span)) update val vid = freshVId (ctx, "record") @@ -444,7 +444,7 @@ fun doExp(ctx, env, UnfixedSyntax.SConExp(span, scon)) = Syntax.SConExp(span, sc | doExp (ctx, env, UnfixedSyntax.FnExp (span, optBar, matches)) = ( doOptBar (ctx, optBar) ; Syntax.FnExp (span, List.map (fn (pat, exp) => (doPat (ctx, env, pat), doExp (ctx, env, exp))) matches) ) - | doExp(ctx, env, UnfixedSyntax.ProjectionExp(span, lab)) = Syntax.ProjectionExp(span, lab) + | doExp (_, _, UnfixedSyntax.ProjectionExp (span, lab)) = Syntax.ProjectionExp (span, lab) | doExp(ctx, env, UnfixedSyntax.ListExp(span, xs)) = Syntax.ListExp(span, Vector.map (fn e => doExp(ctx, env, e)) xs) | doExp(ctx, env, UnfixedSyntax.VectorExp(span, xs)) = Syntax.VectorExp(span, Vector.map (fn e => doExp(ctx, env, e)) xs) | doExp(ctx, env, UnfixedSyntax.PrimExp(span, name, tyargs, args)) @@ -462,7 +462,7 @@ fun doExp(ctx, env, UnfixedSyntax.SConExp(span, scon)) = Syntax.SConExp(span, sc emitNonfatalError (ctx, [span'], "extra semicolon") ; Syntax.SequentialExp (span, Vector.map (fn e => doExp (ctx, env, e)) xs, doExp (ctx, env, y)) ) -and doDecs(ctx, env, nil) = (emptyEnv, nil) +and doDecs (_, _, nil) = (emptyEnv, nil) | doDecs(ctx, env, dec :: decs) = let val (env', dec') = doDec(ctx, env, dec) val (env'', decs') = doDecs(ctx, mergeEnv(env, env'), decs) in (mergeEnv(env', env''), dec' @ decs') @@ -478,14 +478,14 @@ and doDec (ctx, env, UnfixedSyntax.ValDec (span, tyvars, desc, valbind)) = (empt | doDec (ctx, env, UnfixedSyntax.FValDec (span, tyvars, desc, optBar, fvalbind)) = ( doOptBar (ctx, optBar) ; (emptyEnv, [Syntax.RecValDec (span, tyvars, List.map (fn (span, vid, ty) => (span, vid, [], ty)) desc, List.map (fn fvb => doFValBind (ctx, env, fvb)) fvalbind)]) ) - | doDec(ctx, env, UnfixedSyntax.TypeDec(span, typbinds)) = (emptyEnv, [Syntax.TypeDec(span, typbinds)]) - | doDec(ctx, env, UnfixedSyntax.DatatypeDec(span, datbinds, typbinds)) + | doDec (_, _, UnfixedSyntax.TypeDec (span, typbinds)) = (emptyEnv, [Syntax.TypeDec (span, typbinds)]) + | doDec (_, _, UnfixedSyntax.DatatypeDec (span, datbinds, typbinds)) = let fun doConBinds (conbinds : Syntax.ConBind list) : (unit Syntax.IdStatus) Syntax.VIdMap.map = List.foldl (fn (Syntax.ConBind (_, vid, _), map) => (* Syntactic Restriction: vid must not be one of "true", "false", "nil", "::" or "ref". *) Syntax.VIdMap.insert (map, vid, Syntax.ValueConstructor ()) ) Syntax.VIdMap.empty conbinds - val tyConMap = List.foldl (fn (Syntax.DatBind (span, tyvars, tycon, _, conbinds), map) => Syntax.TyConMap.insert (map, tycon, doConBinds conbinds)) Syntax.TyConMap.empty datbinds + val tyConMap = List.foldl (fn (Syntax.DatBind (_, _, tycon, _, conbinds), map) => Syntax.TyConMap.insert (map, tycon, doConBinds conbinds)) Syntax.TyConMap.empty datbinds val valMap = Syntax.TyConMap.foldl (Syntax.VIdMap.unionWith #2 (* should be disjoint *)) Syntax.VIdMap.empty tyConMap val idStatusMap = { valMap = valMap , tyConMap = tyConMap @@ -493,7 +493,7 @@ and doDec (ctx, env, UnfixedSyntax.ValDec (span, tyvars, desc, valbind)) = (empt } in (envWithIdStatusMap idStatusMap, [Syntax.DatatypeDec(span, datbinds, typbinds)]) end - | doDec(ctx, env, UnfixedSyntax.DatatypeRepDec(span, tycon, longtycon)) = let val valMap = case lookupLongTyCon(env, longtycon) of + | doDec (_, env, UnfixedSyntax.DatatypeRepDec (span, tycon, longtycon)) = let val valMap = case lookupLongTyCon (env, longtycon) of SOME valMap => valMap | NONE => Syntax.VIdMap.empty val idStatusMap = { valMap = valMap @@ -508,7 +508,7 @@ and doDec (ctx, env, UnfixedSyntax.ValDec (span, tyvars, desc, valbind)) = (empt (* Syntactic Restriction: vid must not be one of "true", "false", "nil", "::" or "ref". *) Syntax.VIdMap.insert (map, vid, Syntax.ValueConstructor ()) ) Syntax.VIdMap.empty conbinds - val tyConMap = List.foldl (fn (Syntax.DatBind (span, tyvars, tycon, _, conbinds), map) => Syntax.TyConMap.insert (map, tycon, doConBinds conbinds)) Syntax.TyConMap.empty datbinds + val tyConMap = List.foldl (fn (Syntax.DatBind (_, _, tycon, _, conbinds), map) => Syntax.TyConMap.insert (map, tycon, doConBinds conbinds)) Syntax.TyConMap.empty datbinds val valMap = Syntax.TyConMap.foldl (Syntax.VIdMap.unionWith #2 (* should be disjoint *)) Syntax.VIdMap.empty tyConMap val idStatusMap = { valMap = valMap , tyConMap = tyConMap @@ -518,15 +518,15 @@ and doDec (ctx, env, UnfixedSyntax.ValDec (span, tyvars, desc, valbind)) = (empt val (env, decs') = doDecs(ctx, innerEnv, decs) (* not really implemented yet *) in (env, [Syntax.AbstypeDec(span, datbinds, typbinds, decs')]) end - | doDec(ctx, env, UnfixedSyntax.ExceptionDec(span, exbinds)) = let val valMap = List.foldl (fn (Syntax.ExBind(span, vid, _), valMap) => Syntax.VIdMap.insert(valMap, vid, Syntax.ExceptionConstructor) - | (Syntax.ExReplication(span, vid, _), valMap) => Syntax.VIdMap.insert(valMap, vid, Syntax.ExceptionConstructor) (* RHS should be an exception constructor *) - ) Syntax.VIdMap.empty exbinds - val idStatusMap = { valMap = valMap - , tyConMap = Syntax.TyConMap.empty - , strMap = Syntax.StrIdMap.empty - } - in (envWithIdStatusMap idStatusMap, [Syntax.ExceptionDec(span, exbinds)]) - end + | doDec (_, _, UnfixedSyntax.ExceptionDec (span, exbinds)) = let val valMap = List.foldl (fn (Syntax.ExBind (_, vid, _), valMap) => Syntax.VIdMap.insert (valMap, vid, Syntax.ExceptionConstructor) + | (Syntax.ExReplication (_, vid, _), valMap) => Syntax.VIdMap.insert (valMap, vid, Syntax.ExceptionConstructor) (* RHS should be an exception constructor *) + ) Syntax.VIdMap.empty exbinds + val idStatusMap = { valMap = valMap + , tyConMap = Syntax.TyConMap.empty + , strMap = Syntax.StrIdMap.empty + } + in (envWithIdStatusMap idStatusMap, [Syntax.ExceptionDec(span, exbinds)]) + end | doDec(ctx, env, UnfixedSyntax.LocalDec(span, decs1, decs2)) = let val (env', decs1') = doDecs(ctx, env, decs1) val (env'', decs2') = doDecs(ctx, mergeEnv(env, env'), decs2) in (env'', [Syntax.LocalDec(span, decs1', decs2')]) @@ -537,15 +537,15 @@ and doDec (ctx, env, UnfixedSyntax.ValDec (span, tyvars, desc, valbind)) = (empt ) emptyIdStatusMap strids in (envWithIdStatusMap idStatusMap, [Syntax.OpenDec(span, strids)]) end - | doDec (ctx, env, UnfixedSyntax.FixityDec (span, fixity as Syntax.Infix assoc, vids)) + | doDec (_, _, UnfixedSyntax.FixityDec (_, fixity as Syntax.Infix assoc, vids)) = let val fixityMaps = List.foldl (fn (Syntax.ShortVId vid, (m, n)) => (Syntax.VIdMap.insert (m, vid, fixity), n) | (Syntax.InfixVId vid, (m, n)) => (m, Syntax.VIdMap.insert (n, Syntax.MkVId vid, assoc)) ) (Syntax.VIdMap.empty, Syntax.VIdMap.empty) vids in (envWithFixityMap fixityMaps, []) end - | doDec (ctx, env, UnfixedSyntax.FixityDec (span, fixity as Syntax.Nonfix, vids)) + | doDec (ctx, _, UnfixedSyntax.FixityDec (span, fixity as Syntax.Nonfix, vids)) = let val fixityMap = List.foldl (fn (Syntax.ShortVId vid, m) => Syntax.VIdMap.insert (m, vid, fixity) - | (Syntax.InfixVId vid, m) => (emitNonfatalError (ctx, [span], "invalid nonfix declaration for dotted identifier"); m) + | (Syntax.InfixVId _, m) => (emitNonfatalError (ctx, [span], "invalid nonfix declaration for dotted identifier"); m) ) Syntax.VIdMap.empty vids in (envWithFixityMap (fixityMap, Syntax.VIdMap.empty), []) end @@ -649,15 +649,15 @@ and doDec (ctx, env, UnfixedSyntax.ValDec (span, tyvars, desc, valbind)) = (empt in (emptyEnv, [Syntax.OverloadDec(span, class, longtycon, map)]) end | doDec (ctx, env, UnfixedSyntax.EqualityDec (span, typarams, longtycon, exp)) = (emptyEnv, [Syntax.EqualityDec (span, typarams, longtycon, doExp (ctx, env, exp))]) - | doDec (ctx, env, UnfixedSyntax.ESImportDec x) = (emptyEnv, [Syntax.ESImportDec x]) + | doDec (_, _, UnfixedSyntax.ESImportDec x) = (emptyEnv, [Syntax.ESImportDec x]) and doValBind(ctx, env, UnfixedSyntax.PatBind(span, pat, exp)) = Syntax.PatBind(span, doPat(ctx, env, pat), doExp(ctx, env, exp)) and doFValBind(ctx, env, UnfixedSyntax.FValBind(span, rules)) : Syntax.ValBind = let fun doFMRule (UnfixedSyntax.FMRule(_, fpat, optTy, exp)) = (doFPat(ctx, env, fpat), optTy, doExp(ctx, env, exp)) val rules' = List.map doFMRule rules - fun getVIdAndArity (((span, vid, []), _, _) :: xs) = emitError(ctx, [span], "function declaration with no arguments") + fun getVIdAndArity (((span, _, []), _, _) :: _) = emitError (ctx, [span], "function declaration with no arguments") | getVIdAndArity (((span, vid, pats), _, _) :: xs) = checkVIdAndArity(span, vid, length pats, xs) | getVIdAndArity [] = emitError(ctx, [span], "internal error: empty 'fun' rule") - and checkVIdAndArity(span, vid, arity, []) = (vid, arity) + and checkVIdAndArity (_, vid, arity, []) = (vid, arity) | checkVIdAndArity(span, vid, arity, ((span', vid', pats), _, _) :: xs) = if vid = vid' then if arity = length pats then @@ -691,7 +691,7 @@ and doFValBind(ctx, env, UnfixedSyntax.FValBind(span, rules)) : Syntax.ValBind in Syntax.PatBind(span, Syntax.VarPat(span, vid), buildExp(arity, [])) end (* ( ) -> is infix function name *) -and doFPat(ctx, env, UnfixedSyntax.FPat(span1, [UnfixedSyntax.JuxtapositionPat(span2, [pat1, UnfixedSyntax.InfixOrVIdPat(span3, vid), pat3])])) : SourcePos.span * Syntax.VId * Syntax.Pat list +and doFPat (ctx, env, UnfixedSyntax.FPat (span1, [UnfixedSyntax.JuxtapositionPat (_, [pat1, UnfixedSyntax.InfixOrVIdPat (span3, vid), pat3])])) : SourcePos.span * Syntax.VId * Syntax.Pat list = (case getFixityStatus(env, vid) of Syntax.Nonfix => emitError(ctx, [span3], "invalid function declaration: '" ^ Syntax.getVIdName vid ^ "' must be an infix identifier") | Syntax.Infix _ => doInfixFPat(ctx, env, span1, span3, vid, pat1, pat3, []) @@ -700,7 +700,7 @@ and doFPat(ctx, env, UnfixedSyntax.FPat(span1, [UnfixedSyntax.JuxtapositionPat(s | doFPat (ctx, env, UnfixedSyntax.FPat (span1, [pat1, UnfixedSyntax.InfixPat (span4, Syntax.MkQualified ([], vid2)), pat3])) = doInfixFPat (ctx, env, span1, span4, vid2, pat1, pat3, []) (* ( ) ... *) - | doFPat (ctx, env, UnfixedSyntax.FPat (span1, (UnfixedSyntax.JuxtapositionPat (span2, [pat1, UnfixedSyntax.InfixPat (span3, Syntax.MkQualified ([], vid)), pat3]) :: pats))) + | doFPat (ctx, env, UnfixedSyntax.FPat (span1, (UnfixedSyntax.JuxtapositionPat (_, [pat1, UnfixedSyntax.InfixPat (span3, Syntax.MkQualified ([], vid)), pat3]) :: pats))) = doInfixFPat (ctx, env, span1, span3, vid, pat1, pat3, pats) (* ( ) -> or is infix function name *) | doFPat(ctx, env, UnfixedSyntax.FPat(span1, [pat1 as UnfixedSyntax.JuxtapositionPat(span2, [pat11, UnfixedSyntax.InfixOrVIdPat(span3, vid1), pat13]), pat2 as UnfixedSyntax.InfixOrVIdPat(span4, vid2), pat3])) @@ -710,7 +710,7 @@ and doFPat(ctx, env, UnfixedSyntax.FPat(span1, [UnfixedSyntax.JuxtapositionPat(s | (_, Syntax.Infix _) => doInfixFPat(ctx, env, span1, span4, vid2, pat1, pat3, []) ) (* ( ) ... -> is infix function name *) - | doFPat(ctx, env, UnfixedSyntax.FPat(span1, UnfixedSyntax.JuxtapositionPat(span2, [pat11, UnfixedSyntax.InfixOrVIdPat(span3, vid), pat13]) :: pats)) + | doFPat (ctx, env, UnfixedSyntax.FPat (span1, UnfixedSyntax.JuxtapositionPat (_, [pat11, UnfixedSyntax.InfixOrVIdPat (span3, vid), pat13]) :: pats)) = (case getFixityStatus(env, vid) of Syntax.Nonfix => emitError(ctx, [span3], "invalid function declaration: '" ^ Syntax.getVIdName vid ^ "' must be an infix identifier") | Syntax.Infix _ => doInfixFPat(ctx, env, span1, span3, vid, pat11, pat13, pats) @@ -737,51 +737,51 @@ and doFPat(ctx, env, UnfixedSyntax.FPat(span1, [UnfixedSyntax.JuxtapositionPat(s Syntax.Nonfix => doPrefixFPat(ctx, env, span, vid, pats) | Syntax.Infix _ => emitError(ctx, [span], "invalid function declaration: '" ^ Syntax.getVIdName vid ^ "' must be prefixed by an 'op'") ) - | doFPat(ctx, env, UnfixedSyntax.FPat (span, _)) + | doFPat (ctx, _, UnfixedSyntax.FPat (span, _)) = emitError(ctx, [span], "invalid function declaration") and doInfixFPat(ctx, env, span, vidspan, vid, patL, patR, pats) = (vidspan, vid, Syntax.TuplePat(span, [doPat(ctx, env, patL), doPat(ctx, env, patR)]) :: List.map (fn p => doPat(ctx, env, p)) pats) and doPrefixFPat(ctx, env, span, vid, pats) = (span, vid, List.map (fn p => doPat(ctx, env, p)) pats) -fun doSigExp(ctx, env, Syntax.BasicSigExp(span, specs)) : IdStatusMap = doSpecs(ctx, env, specs) +fun doSigExp (ctx, env, Syntax.BasicSigExp (_, specs)) : IdStatusMap = doSpecs (ctx, env, specs) | doSigExp(ctx, env, Syntax.SigIdExp(span, sigid)) = (case Syntax.SigIdMap.find(#sigMap env, sigid) of SOME m => m | NONE => emitError(ctx, [span], "signature not found: " ^ Syntax.print_SigId sigid) ) - | doSigExp (ctx, env, Syntax.TypeRealisationExp (span, sigexp, tyvars, longtycon, ty, _)) = doSigExp (ctx, env, sigexp) (* does not affect idstatus *) + | doSigExp (ctx, env, Syntax.TypeRealisationExp (_, sigexp, _, _, _, _)) = doSigExp (ctx, env, sigexp) (* does not affect idstatus *) and doSpecs(ctx, env, specs) = List.foldl (fn (spec, m) => mergeIdStatusMap(m, doSpec(ctx, mergeEnv(env, envWithIdStatusMap m), spec))) emptyIdStatusMap specs -and doSpec(ctx, env, Syntax.ValDesc(span, descs)) = emptyIdStatusMap - | doSpec(ctx, env, Syntax.TypeDesc(span, descs)) = emptyIdStatusMap - | doSpec(ctx, env, Syntax.EqtypeDesc(span, descs)) = emptyIdStatusMap - | doSpec (ctx, env, Syntax.DatDesc (span, descs, typbinds)) = List.foldl (fn ((tyvars, tycon, optBar, condescs), { valMap, tyConMap, strMap }) => - let val valMap' = List.foldl (fn (Syntax.ConBind (_, vid, _), m) => - Syntax.VIdMap.insert (m, vid, Syntax.ValueConstructor ()) - ) Syntax.VIdMap.empty condescs - in { valMap = Syntax.VIdMap.unionWith #2 (valMap, valMap') - , tyConMap = Syntax.TyConMap.insert (tyConMap, tycon, valMap') - , strMap = strMap } - end - ) emptyIdStatusMap descs - | doSpec(ctx, env, Syntax.DatatypeRepSpec(span, tycon, longtycon)) = let val valMap = case lookupLongTyCon(env, longtycon) of - SOME m => m - | NONE => Syntax.VIdMap.empty - in { valMap = valMap - , tyConMap = Syntax.TyConMap.singleton(tycon, valMap) - , strMap = Syntax.StrIdMap.empty - } - end - | doSpec(ctx, env, Syntax.ExDesc(span, descs)) = { valMap = List.foldl (fn ((vid, _), m) => Syntax.VIdMap.insert(m, vid, Syntax.ExceptionConstructor)) Syntax.VIdMap.empty descs - , tyConMap = Syntax.TyConMap.empty - , strMap = Syntax.StrIdMap.empty - } - | doSpec(ctx, env, Syntax.StrDesc(span, descs)) = let val strMap = List.foldl (fn ((strid, sigexp), strMap) => Syntax.StrIdMap.insert(strMap, strid, MkIdStatusMap (doSigExp(ctx, env, sigexp)))) Syntax.StrIdMap.empty descs - in { valMap = Syntax.VIdMap.empty - , tyConMap = Syntax.TyConMap.empty - , strMap = strMap - } - end - | doSpec(ctx, env, Syntax.Include(span, sigexp)) = doSigExp(ctx, env, sigexp) - | doSpec(ctx, env, Syntax.Sharing(span, specs, longtycons)) = doSpecs(ctx, env, specs) - | doSpec(ctx, env, Syntax.SharingStructure(span, specs, longstrids)) = doSpecs(ctx, env, specs) - | doSpec(ctx, env, Syntax.TypeAliasDesc(span, descs)) = emptyIdStatusMap +and doSpec (_, _, Syntax.ValDesc (_, _)) = emptyIdStatusMap + | doSpec (_, _, Syntax.TypeDesc (_, _)) = emptyIdStatusMap + | doSpec (_, _, Syntax.EqtypeDesc (_, _)) = emptyIdStatusMap + | doSpec (_, _, Syntax.DatDesc (_, descs, _)) = List.foldl (fn ((_, tycon, _, condescs), { valMap, tyConMap, strMap }) => + let val valMap' = List.foldl (fn (Syntax.ConBind (_, vid, _), m) => + Syntax.VIdMap.insert (m, vid, Syntax.ValueConstructor ()) + ) Syntax.VIdMap.empty condescs + in { valMap = Syntax.VIdMap.unionWith #2 (valMap, valMap') + , tyConMap = Syntax.TyConMap.insert (tyConMap, tycon, valMap') + , strMap = strMap } + end + ) emptyIdStatusMap descs + | doSpec (_, env, Syntax.DatatypeRepSpec (_, tycon, longtycon)) = let val valMap = case lookupLongTyCon (env, longtycon) of + SOME m => m + | NONE => Syntax.VIdMap.empty + in { valMap = valMap + , tyConMap = Syntax.TyConMap.singleton (tycon, valMap) + , strMap = Syntax.StrIdMap.empty + } + end + | doSpec (_, _, Syntax.ExDesc (_, descs)) = { valMap = List.foldl (fn ((vid, _), m) => Syntax.VIdMap.insert (m, vid, Syntax.ExceptionConstructor)) Syntax.VIdMap.empty descs + , tyConMap = Syntax.TyConMap.empty + , strMap = Syntax.StrIdMap.empty + } + | doSpec (ctx, env, Syntax.StrDesc (_, descs)) = let val strMap = List.foldl (fn ((strid, sigexp), strMap) => Syntax.StrIdMap.insert (strMap, strid, MkIdStatusMap (doSigExp (ctx, env, sigexp)))) Syntax.StrIdMap.empty descs + in { valMap = Syntax.VIdMap.empty + , tyConMap = Syntax.TyConMap.empty + , strMap = strMap + } + end + | doSpec (ctx, env, Syntax.Include (_, sigexp)) = doSigExp (ctx, env, sigexp) + | doSpec (ctx, env, Syntax.Sharing (_, specs, _)) = doSpecs (ctx, env, specs) + | doSpec (ctx, env, Syntax.SharingStructure (_, specs, _)) = doSpecs (ctx, env, specs) + | doSpec (_, _, Syntax.TypeAliasDesc (_, _)) = emptyIdStatusMap (*: val doStrExp : Context * Env * UnfixedSyntax.Dec Syntax.StrExp -> IdStatusMap * Syntax.Dec Syntax.StrExp and doStrDec : Context * Env * UnfixedSyntax.Dec Syntax.StrDec -> Env * (Syntax.Dec Syntax.StrDec) list @@ -828,7 +828,7 @@ and doStrDec(ctx, env, Syntax.CoreDec(span, dec)) = let val (env', decs) = doDec val (env'', decs') = doStrDecs(ctx, mergeEnv(env, env'), decs') in (env'', [Syntax.LocalStrDec(span, decs, decs')]) end -and doStrDecs(ctx, env, []) = (emptyEnv, []) +and doStrDecs (_, _, []) = (emptyEnv, []) | doStrDecs(ctx, env, dec :: decs) = let val (env', dec) = doStrDec(ctx, env, dec) val (env'', decs) = doStrDecs(ctx, mergeEnv(env, env'), decs) in (mergeEnv(env', env''), dec @ decs) @@ -859,12 +859,12 @@ fun doTopDec(ctx, env, Syntax.StrDec(strdec)) = let val (env, strdecs) = doStrDe val env' = envWithFunMap (List.foldl (fn ((_, funid, ids, _), m) => Syntax.FunIdMap.insert(m, funid, ids)) Syntax.FunIdMap.empty funbinds') in (env', [Syntax.FunDec (List.map (fn (span, funid, _, exp) => (span, funid, exp)) funbinds')]) end -fun doTopDecs(ctx, env, []) : Env * (Syntax.Dec Syntax.TopDec) list = (emptyEnv, []) +fun doTopDecs (_, _, []) : Env * (Syntax.Dec Syntax.TopDec) list = (emptyEnv, []) | doTopDecs(ctx, env, dec :: decs) = let val (env', dec) = doTopDec(ctx, env, dec) val (env'', decs) = doTopDecs(ctx, mergeEnv(env, env'), decs) in (mergeEnv(env', env''), dec @ decs) end -fun doProgram(ctx, env, []) : Env * ((Syntax.Dec Syntax.TopDec) list) list = (emptyEnv, []) +fun doProgram (_, _, []) : Env * ((Syntax.Dec Syntax.TopDec) list) list = (emptyEnv, []) | doProgram(ctx, env, dec :: decs) = let val (env', dec) = doTopDecs(ctx, env, dec) val (env'', decs) = doProgram(ctx, mergeEnv(env, env'), decs) in (mergeEnv(env', env''), dec :: decs) @@ -920,7 +920,7 @@ local | collectExp(bound, IfThenElseExp(_, x, y, z)) = union3(collectExp(bound, x), collectExp(bound, y), collectExp(bound, z)) | collectExp(bound, CaseExp(_, x, match)) = TyVarSet.union(collectExp(bound, x), collectMatch(bound, match)) | collectExp(bound, FnExp(_, match)) = collectMatch(bound, match) - | collectExp(bound, ProjectionExp(_, lab)) = TyVarSet.empty + | collectExp (_, ProjectionExp (_, _)) = TyVarSet.empty | collectExp(bound, ListExp(_, xs)) = Vector.foldl (fn (e, set) => TyVarSet.union(collectExp(bound, e), set)) TyVarSet.empty xs | collectExp(bound, VectorExp(_, xs)) = Vector.foldl (fn (e, set) => TyVarSet.union(collectExp(bound, e), set)) TyVarSet.empty xs | collectExp(bound, PrimExp(_, _, tyargs, args)) = let val acc = Vector.foldl (fn (ty, set) => TyVarSet.union(set, TyVarSet.difference(freeTyVarsInTy(bound, ty), bound))) TyVarSet.empty tyargs @@ -929,28 +929,22 @@ local | collectExp (bound, SequentialExp (_, xs, y)) = Vector.foldl (fn (x, set) => TyVarSet.union (collectExp (bound, x), set)) (collectExp (bound, y)) xs and collectMatch(bound, xs) = List.foldl (fn ((pat, e), set) => TyVarSet.union(freeTyVarsInPat(bound, pat), TyVarSet.union(collectExp(bound, e), set))) TyVarSet.empty xs and collectValBind(bound, PatBind(_, pat, e)) = TyVarSet.union(freeTyVarsInPat(bound, pat), collectExp(bound, e)) - and collectFRule(bound, (pats, optTy, exp)) = let val tyVarsInPats = List.foldl TyVarSet.union TyVarSet.empty (List.map (fn pat => freeTyVarsInPat(bound, pat)) pats) - val tyVarsInOptTy = case optTy of - NONE => TyVarSet.empty - | SOME expTy => TyVarSet.difference(freeTyVarsInTy(bound, expTy), bound) - in union3(tyVarsInPats, tyVarsInOptTy, collectExp(bound, exp)) - end - and collectDec(bound, ValDec _) = TyVarSet.empty - | collectDec(bound, RecValDec _) = TyVarSet.empty + and collectDec (_, ValDec _) = TyVarSet.empty + | collectDec (_, RecValDec _) = TyVarSet.empty | collectDec(bound, TypeDec(_, typbinds)) = List.foldl (fn (TypBind (_, tyvars, _, ty), acc) => TyVarSet.union(freeTyVarsInTy(TyVarSet.addList(bound, tyvars), ty), acc)) TyVarSet.empty typbinds | collectDec(bound, DatatypeDec(_, datbinds, typbinds)) = List.foldl (fn (datbind, acc) => TyVarSet.union(collectDatBind(bound, datbind), acc)) (List.foldl (fn (TypBind (_, tyvars, _, ty), acc) => TyVarSet.union(freeTyVarsInTy(TyVarSet.addList(bound, tyvars), ty), acc)) TyVarSet.empty typbinds) datbinds - | collectDec(bound, DatatypeRepDec(_, _, _)) = TyVarSet.empty + | collectDec (_, DatatypeRepDec (_, _, _)) = TyVarSet.empty | collectDec(bound, AbstypeDec(_, datbinds, typbinds, decs)) = let val acc = List.foldl (fn (TypBind (_, tyvars, _, ty), acc) => TyVarSet.union(freeTyVarsInTy(TyVarSet.addList(bound, tyvars), ty), acc)) TyVarSet.empty typbinds val acc = List.foldl (fn (datbind, acc) => TyVarSet.union(collectDatBind(bound, datbind), acc)) acc datbinds in List.foldl (fn (dec, acc) => TyVarSet.union(collectDec(bound, dec), acc)) acc decs end - | collectDec(bound, ExceptionDec(span, exbinds)) = List.foldl (fn (ExBind(span, vid, SOME ty), acc) => TyVarSet.union(freeTyVarsInTy(bound, ty), acc) - | (ExBind(span, vid, NONE), acc) => acc - | (ExReplication(_, _, _), acc) => acc) TyVarSet.empty exbinds + | collectDec (bound, ExceptionDec (_, exbinds)) = List.foldl (fn (ExBind (_, _, SOME ty), acc) => TyVarSet.union (freeTyVarsInTy (bound, ty), acc) + | (ExBind (_, _, NONE), acc) => acc + | (ExReplication (_, _, _), acc) => acc) TyVarSet.empty exbinds | collectDec(bound, LocalDec(_, decs1, decs2)) = List.foldl (fn (dec, acc) => TyVarSet.union(collectDec(bound, dec), acc)) (List.foldl (fn (dec, acc) => TyVarSet.union(collectDec(bound, dec), acc)) TyVarSet.empty decs1) decs2 - | collectDec(bound, OpenDec _) = TyVarSet.empty + | collectDec (_, OpenDec _) = TyVarSet.empty | collectDec(bound, OverloadDec(_, _, _, map)) = OverloadKeyMap.foldl (fn (exp, acc) => TyVarSet.union(acc, collectExp(bound, exp))) TyVarSet.empty map - | collectDec (bound, EqualityDec (_, typarams, longtycon, exp)) = collectExp (TyVarSet.addList (bound, typarams), exp) + | collectDec (bound, EqualityDec (_, typarams, _, exp)) = collectExp (TyVarSet.addList (bound, typarams), exp) | collectDec (bound, ESImportDec { sourceSpan = _, pure = _, specs, moduleName = _ }) = List.foldl (fn ((_, _, SOME ty), acc) => TyVarSet.union (freeTyVarsInTy (bound, ty), acc) | ((_, _, NONE), acc) => acc) TyVarSet.empty specs and collectDatBind (bound, DatBind (_, tyvars, _, _, conbinds)) = let val bound = TyVarSet.addList (bound, tyvars) @@ -959,7 +953,6 @@ local in List.foldl (fn (conbind, acc) => TyVarSet.union (doConBind conbind, acc)) TyVarSet.empty conbinds end in -val unguardedTyVarsInExp : TyVarSet.set * Exp -> TyVarSet.set = collectExp val unguardedTyVarsInValBind : TyVarSet.set * ValBind list -> TyVarSet.set = fn (bound, valbinds) => List.foldl (fn (valbind, set) => TyVarSet.union(set, collectValBind(bound, valbind))) TyVarSet.empty valbinds end (* local *) @@ -978,21 +971,21 @@ local val bound'' = TyVarSet.union (bound', unguarded) in RecValDec (span, expbound', List.map (scopeTyVarsInValDesc bound'') desc, List.map (fn vb => doValBind (bound'', vb)) valbind) end - | doDec(bound, dec as TypeDec _) = dec - | doDec(bound, dec as DatatypeDec _) = dec - | doDec(bound, dec as DatatypeRepDec _) = dec + | doDec (_, dec as TypeDec _) = dec + | doDec (_, dec as DatatypeDec _) = dec + | doDec (_, dec as DatatypeRepDec _) = dec | doDec(bound, AbstypeDec(span, datbinds, typbinds, decs)) = AbstypeDec(span, datbinds, typbinds, doDecList(bound, decs)) - | doDec(bound, dec as ExceptionDec _) = dec + | doDec (_, dec as ExceptionDec _) = dec | doDec(bound, LocalDec(span, xs, ys)) = LocalDec(span, doDecList(bound, xs), doDecList(bound, ys)) - | doDec(bound, dec as OpenDec _) = dec - | doDec(bound, dec as OverloadDec _) = dec + | doDec (_, dec as OpenDec _) = dec + | doDec (_, dec as OverloadDec _) = dec | doDec (bound, EqualityDec (span, typarams, longtycon, exp)) = EqualityDec (span, typarams, longtycon, doExp (TyVarSet.addList (bound, typarams), exp)) - | doDec (bound, dec as ESImportDec _) = dec + | doDec (_, dec as ESImportDec _) = dec and doDecList(bound, decls) = List.map (fn x => doDec(bound, x)) decls and doValBind(bound, PatBind(span, pat, e)) = PatBind(span, pat, doExp(bound, e)) - and doExp(bound, exp as SConExp _) = exp - | doExp(bound, exp as VarExp _) = exp - | doExp(bound, exp as RecordExp _) = exp + and doExp (_, exp as SConExp _) = exp + | doExp (_, exp as VarExp _) = exp + | doExp (_, exp as RecordExp _) = exp | doExp(bound, LetInExp(span, decls, exp)) = LetInExp(span, doDecList(bound, decls), doExp(bound, exp)) | doExp(bound, AppExp(span, x, y)) = AppExp(span, doExp(bound, x), doExp(bound, y)) | doExp(bound, TypedExp(span, x, ty)) = TypedExp(span, doExp(bound, x), ty) @@ -1001,7 +994,7 @@ local | doExp(bound, IfThenElseExp(span, x, y, z)) = IfThenElseExp(span, doExp(bound, x), doExp(bound, y), doExp(bound, z)) | doExp(bound, CaseExp(span, x, match)) = CaseExp(span, doExp(bound, x), doMatch(bound, match)) | doExp(bound, FnExp(span, match)) = FnExp(span, doMatch(bound, match)) - | doExp(bound, exp as ProjectionExp _) = exp + | doExp (_, exp as ProjectionExp _) = exp | doExp(bound, ListExp(span, xs)) = ListExp(span, Vector.map (fn x => doExp(bound, x)) xs) | doExp(bound, VectorExp(span, xs)) = VectorExp(span, Vector.map (fn x => doExp(bound, x)) xs) | doExp(bound, PrimExp(span, name, tyargs, args)) = PrimExp(span, name, tyargs, Vector.map (fn x => doExp(bound, x)) args) @@ -1045,7 +1038,7 @@ type context = { messageHandler : Message.handler fun emitError ({ messageHandler, ... } : context, spans, message) = Message.error (messageHandler, spans, "syntax", message) -fun checkOptBar (ctx, Syntax.NO_BAR) = () +fun checkOptBar (_, Syntax.NO_BAR) = () | checkOptBar (ctx, Syntax.HAS_BAR span) = if #allowOptBar (#languageOptions ctx) then () else @@ -1053,7 +1046,7 @@ fun checkOptBar (ctx, Syntax.NO_BAR) = () (*: val checkRow : (S.Label * 'a) list -> bool (* returns true if the same label is bound twice *) *) fun checkRow (row : (S.Label * 'a) list) = doCheckRow (S.LabelSet.empty, row) -and doCheckRow (seen, []) = false +and doCheckRow (_, []) = false | doCheckRow (seen, (label, _) :: xs) = if S.LabelSet.member (seen, label) then true else @@ -1061,7 +1054,7 @@ and doCheckRow (seen, []) = false (*: val checkTyVarSeq : context * SourcePos.span * S.TyVar list -> unit *) fun checkTyVarSeq (ctx, span, xs: S.TyVar list) = doCheckTyVarSeq (ctx, span, S.TyVarSet.empty, xs) -and doCheckTyVarSeq (ctx, span, seen, []) = () +and doCheckTyVarSeq (_, _, _, []) = () | doCheckTyVarSeq (ctx, span, seen, tv :: xs) = ( if S.TyVarSet.member (seen, tv) then emitError (ctx, [span], "no tyvarseq may contain the same tyvar twice") else @@ -1070,13 +1063,13 @@ and doCheckTyVarSeq (ctx, span, seen, []) = () ) (*: val doTy : context -> S.Ty -> unit *) -fun doTy ctx (S.TyVar span) = () +fun doTy _ (S.TyVar _) = () | doTy ctx (S.RecordType (span, fields, optBaseTy)) = if checkRow fields then emitError (ctx, [span], "no type-expression row may bind the same label twice") else Option.app (doTy ctx) optBaseTy - | doTy ctx (S.TyCon (span, tyargs, longtycon)) = List.app (doTy ctx) tyargs - | doTy ctx (S.FnType (span, s, t)) = ( doTy ctx s ; doTy ctx t ) + | doTy ctx (S.TyCon (_, tyargs, _)) = List.app (doTy ctx) tyargs + | doTy ctx (S.FnType (_, s, t)) = ( doTy ctx s ; doTy ctx t ) (*: val freeTyVarsInTypeDec : S.TyVar list -> S.Ty -> SourcePos.span list *) fun freeTyVarsInTypeDec tyvarseq @@ -1101,9 +1094,9 @@ fun invalidConstructorNames (ctx : context) = if #allowBindEqual (#languageOptio invalidConstructorNames1 (*: val doPat : context -> S.Pat -> unit *) -fun doPat ctx (S.WildcardPat _) = () +fun doPat _ (S.WildcardPat _) = () | doPat ctx (S.SConPat (span, S.RealConstant _)) = emitError (ctx, [span], "no real constant may occur in a pattern") - | doPat ctx (S.SConPat _) = () + | doPat _ (S.SConPat _) = () | doPat ctx (S.VarPat (span, vid)) = if S.VIdSet.member (invalidBoundNames ctx, vid) then emitError (ctx, [span], "invalid bound name") else @@ -1114,8 +1107,8 @@ fun doPat ctx (S.WildcardPat _) = () () ; Option.app (doPat ctx) ellipsis ) - | doPat ctx (S.ConPat (_, _, NONE)) = () - | doPat ctx (S.ConPat (_, longvid, SOME pat)) = doPat ctx pat + | doPat _ (S.ConPat (_, _, NONE)) = () + | doPat ctx (S.ConPat (_, _, SOME pat)) = doPat ctx pat | doPat ctx (S.TypedPat (_, pat, ty)) = ( doTy ctx ty ; doPat ctx pat ) | doPat ctx (S.LayeredPat (span, vid, optTy, pat)) = ( if S.VIdSet.member (invalidBoundNames ctx, vid) then emitError (ctx, [span], "invalid bound name") @@ -1131,8 +1124,8 @@ fun doPat ctx (S.WildcardPat _) = () ; Vector.app (doPat ctx) pats ) -fun doValSpec (ctx, env, spec : (SourcePos.span * S.VId * S.TyVar list * S.Ty) list) : unit - = ignore (List.foldl (fn ((span, vid, tyvars, ty), set) => +fun doValSpec (ctx, _, spec : (SourcePos.span * S.VId * S.TyVar list * S.Ty) list) : unit + = ignore (List.foldl (fn ((span, vid, _, ty), set) => ( doTy ctx ty ; if S.VIdSet.member (set, vid) then emitError (ctx, [span], "duplicate identifier in signature comment") @@ -1147,34 +1140,34 @@ val doExp : context * S.TyVarSet.set -> S.Exp -> unit and doDec : context * S.TyVarSet.set -> S.Dec -> unit and doValBinds : context * S.TyVarSet.set -> S.ValBind list -> unit *) -fun doExp (ctx : context, env : S.TyVarSet.set) (S.SConExp span) = () - | doExp (ctx, env) (S.VarExp span) = () +fun doExp (_ : context, _ : S.TyVarSet.set) (S.SConExp _) = () + | doExp (_, _) (S.VarExp _) = () | doExp (ctx, env) (S.RecordExp (span, fields, optBase)) = ( if checkRow fields then emitError (ctx, [span], "no expression row may bind the same label twice") else () - ; List.app (fn (label, exp) => doExp (ctx, env) exp) fields + ; List.app (fn (_, exp) => doExp (ctx, env) exp) fields ; Option.app (doExp (ctx, env)) optBase ) - | doExp (ctx, env) (S.LetInExp (span, decls, exp)) = ( List.app (doDec (ctx, env)) decls ; doExp (ctx, env) exp ) - | doExp (ctx, env) (S.AppExp (span, e1, e2)) = ( doExp (ctx, env) e1 ; doExp (ctx, env) e2 ) - | doExp (ctx, env) (S.TypedExp (span, exp, ty)) = ( doExp (ctx, env) exp ; doTy ctx ty ) - | doExp (ctx, env) (S.HandleExp (span, exp, matches)) = ( doExp (ctx, env) exp ; doMatches (ctx, env) matches ) - | doExp (ctx, env) (S.RaiseExp (span, exp)) = doExp (ctx, env) exp - | doExp (ctx, env) (S.IfThenElseExp (span, exp1, exp2, exp3)) = ( doExp (ctx, env) exp1 ; doExp (ctx, env) exp2 ; doExp (ctx, env) exp3 ) - | doExp (ctx, env) (S.CaseExp (span, exp, matches)) = ( doExp (ctx, env) exp ; doMatches (ctx, env) matches ) - | doExp (ctx, env) (S.FnExp (span, matches)) = doMatches (ctx, env) matches - | doExp (ctx, env) (S.ProjectionExp (span, label)) = () - | doExp (ctx, env) (S.ListExp (span, exps)) = Vector.app (fn exp => doExp (ctx, env) exp) exps + | doExp (ctx, env) (S.LetInExp (_, decls, exp)) = ( List.app (doDec (ctx, env)) decls ; doExp (ctx, env) exp ) + | doExp (ctx, env) (S.AppExp (_, e1, e2)) = ( doExp (ctx, env) e1 ; doExp (ctx, env) e2 ) + | doExp (ctx, env) (S.TypedExp (_, exp, ty)) = ( doExp (ctx, env) exp ; doTy ctx ty ) + | doExp (ctx, env) (S.HandleExp (_, exp, matches)) = ( doExp (ctx, env) exp ; doMatches (ctx, env) matches ) + | doExp (ctx, env) (S.RaiseExp (_, exp)) = doExp (ctx, env) exp + | doExp (ctx, env) (S.IfThenElseExp (_, exp1, exp2, exp3)) = ( doExp (ctx, env) exp1 ; doExp (ctx, env) exp2 ; doExp (ctx, env) exp3 ) + | doExp (ctx, env) (S.CaseExp (_, exp, matches)) = ( doExp (ctx, env) exp ; doMatches (ctx, env) matches ) + | doExp (ctx, env) (S.FnExp (_, matches)) = doMatches (ctx, env) matches + | doExp (_, _) (S.ProjectionExp (_, _)) = () + | doExp (ctx, env) (S.ListExp (_, exps)) = Vector.app (fn exp => doExp (ctx, env) exp) exps | doExp (ctx, env) (S.VectorExp (span, exps)) = ( if #allowVectorExps (#languageOptions ctx) then () else emitError (ctx, [span], "vector expression is not allowed here; you may want to set \"allowVectorExps true\"") ; Vector.app (fn exp => doExp (ctx, env) exp) exps ) - | doExp (ctx, env) (S.PrimExp (span, primOp, tyargs, args)) = ( Vector.app (doTy ctx) tyargs ; Vector.app (doExp (ctx, env)) args ) - | doExp (ctx, env) (S.SequentialExp (span, xs, y)) = ( Vector.app (doExp (ctx, env)) xs ; doExp (ctx, env) y ) + | doExp (ctx, env) (S.PrimExp (_, _, tyargs, args)) = ( Vector.app (doTy ctx) tyargs ; Vector.app (doExp (ctx, env)) args ) + | doExp (ctx, env) (S.SequentialExp (_, xs, y)) = ( Vector.app (doExp (ctx, env)) xs ; doExp (ctx, env) y ) and doMatches (ctx, env) matches = List.app (fn (pat, exp) => ( doPat ctx pat ; doExp (ctx, env) exp) ) matches and doDec (ctx : context, env : S.TyVarSet.set) (S.ValDec (span, tyvarseq, desc, valbinds)) = let val tyvars = S.TyVarSet.fromList tyvarseq @@ -1194,7 +1187,7 @@ and doDec (ctx : context, env : S.TyVarSet.set) (S.ValDec (span, tyvarseq, desc, ; doValSpec (ctx, env, desc) ; doValBinds (ctx, S.TyVarSet.union (env, tyvars)) valbinds end - | doDec (ctx, env) (S.TypeDec (span, typbinds)) + | doDec (ctx, _) (S.TypeDec (_, typbinds)) = ignore (List.foldl (fn (S.TypBind (span, tyvarseq, tycon, ty), set) => ( checkTyVarSeq (ctx, span, tyvarseq) ; doTy ctx ty @@ -1211,7 +1204,7 @@ and doDec (ctx : context, env : S.TyVarSet.set) (S.ValDec (span, tyvarseq, desc, ; S.TyConSet.add (set, tycon) ) ) S.TyConSet.empty typbinds) - | doDec (ctx, env) (S.DatatypeDec (span, datbinds, withtypebinds)) + | doDec (ctx, _) (S.DatatypeDec (_, datbinds, withtypebinds)) = let val set = #ty (List.foldl (fn (S.DatBind (span, tyvarseq, tycon, optBar, conbinds), { v, ty }) => ( checkTyVarSeq (ctx, span, tyvarseq) ; checkOptBar (ctx, optBar) @@ -1263,8 +1256,8 @@ and doDec (ctx : context, env : S.TyVarSet.set) (S.ValDec (span, tyvarseq, desc, ) ) set withtypebinds) end - | doDec (ctx, env) (S.DatatypeRepDec (span, tycon, longtycon)) = () - | doDec (ctx, env) (S.AbstypeDec (span, datbinds, withtypebinds, decs)) + | doDec (_, _) (S.DatatypeRepDec (_, _, _)) = () + | doDec (ctx, env) (S.AbstypeDec (_, datbinds, withtypebinds, decs)) = let val set = #ty (List.foldl (fn (S.DatBind (span, tyvarseq, tycon, optBar, conbinds), { v, ty }) => ( checkTyVarSeq (ctx, span, tyvarseq) ; checkOptBar (ctx, optBar) @@ -1298,7 +1291,7 @@ and doDec (ctx : context, env : S.TyVarSet.set) (S.ValDec (span, tyvarseq, desc, ) set withtypebinds in List.app (doDec (ctx, env)) decs end - | doDec (ctx, env) (S.ExceptionDec (span, exbinds)) + | doDec (ctx, _) (S.ExceptionDec (_, exbinds)) = ignore (List.foldl (fn (S.ExBind (span, vid, optTy), set) => ( Option.app (doTy ctx) optTy ; if Syntax.VIdSet.member (invalidConstructorNames ctx, vid) then @@ -1311,7 +1304,7 @@ and doDec (ctx : context, env : S.TyVarSet.set) (S.ValDec (span, tyvarseq, desc, () ; Syntax.VIdSet.add (set, vid) ) - | (S.ExReplication (span, vid, longvid), set) => + | (S.ExReplication (span, vid, _), set) => ( if Syntax.VIdSet.member (invalidConstructorNames ctx, vid) then emitError (ctx, [span], "invalid constructor name") else @@ -1323,13 +1316,13 @@ and doDec (ctx : context, env : S.TyVarSet.set) (S.ValDec (span, tyvarseq, desc, ; Syntax.VIdSet.add (set, vid) ) ) Syntax.VIdSet.empty exbinds) - | doDec (ctx, env) (S.LocalDec (span, decs1, decs2)) = ( List.app (doDec (ctx, env)) decs1 - ; List.app (doDec (ctx, env)) decs2 - ) - | doDec (ctx, env) (S.OpenDec (span, longstrids)) = () - | doDec (ctx, env) (S.OverloadDec _) = () - | doDec (ctx, env) (S.EqualityDec (span, typarams, longtycon, exp)) = doExp (ctx, env) exp - | doDec (ctx, env) (S.ESImportDec { sourceSpan, pure = _, specs, moduleName = _ }) + | doDec (ctx, env) (S.LocalDec (_, decs1, decs2)) = ( List.app (doDec (ctx, env)) decs1 + ; List.app (doDec (ctx, env)) decs2 + ) + | doDec (_, _) (S.OpenDec (_, _)) = () + | doDec (_, _) (S.OverloadDec _) = () + | doDec (ctx, env) (S.EqualityDec (_, _, _, exp)) = doExp (ctx, env) exp + | doDec (ctx, _) (S.ESImportDec { sourceSpan, pure = _, specs, moduleName = _ }) = let fun checkVId vid = if S.VIdSet.member (invalidBoundNames ctx, vid) then emitError (ctx, [sourceSpan], "invalid bound name") else @@ -1409,7 +1402,7 @@ fun doSpec ctx (S.ValDesc (span, descs)) = ignore (List.foldl (fn ((vid, ty), se ) ) set withtypedescs) end - | doSpec ctx (S.DatatypeRepSpec (span, tycon, longtycon)) = () + | doSpec _ (S.DatatypeRepSpec (_, _, _)) = () | doSpec ctx (S.ExDesc (span, descs)) = ignore (List.foldl (fn ((vid, optTy), set) => ( Option.app (doTy ctx) optTy ; if Syntax.VIdSet.member (invalidConstructorNames ctx, vid) then @@ -1432,9 +1425,9 @@ fun doSpec ctx (S.ValDesc (span, descs)) = ignore (List.foldl (fn ((vid, ty), se ; Syntax.StrIdSet.add (set, strid) ) ) Syntax.StrIdSet.empty strdescs) - | doSpec ctx (S.Include (span, sigexp)) = doSigExp ctx sigexp - | doSpec ctx (S.Sharing (span, specs, longtycons)) = doSpecs ctx (span, specs) - | doSpec ctx (S.SharingStructure (span, specs, longstrids)) = doSpecs ctx (span, specs) + | doSpec ctx (S.Include (_, sigexp)) = doSigExp ctx sigexp + | doSpec ctx (S.Sharing (span, specs, _)) = doSpecs ctx (span, specs) + | doSpec ctx (S.SharingStructure (span, specs, _)) = doSpecs ctx (span, specs) | doSpec ctx (S.TypeAliasDesc (span, descs)) = ignore (List.foldl (fn ((tyvarseq, tycon, ty), set) => ( checkTyVarSeq (ctx, span, tyvarseq) ; doTy ctx ty @@ -1445,10 +1438,10 @@ fun doSpec ctx (S.ValDesc (span, descs)) = ignore (List.foldl (fn ((vid, ty), se ; Syntax.TyConSet.add (set, tycon) ) ) Syntax.TyConSet.empty descs) -and doSpecs ctx (span, specs) = List.app (doSpec ctx) specs +and doSpecs ctx (_ (* span *), specs) = List.app (doSpec ctx) specs and doSigExp ctx (S.BasicSigExp (span, specs)) = doSpecs ctx (span, specs) - | doSigExp ctx (S.SigIdExp (_, _)) = () - | doSigExp ctx (S.TypeRealisationExp (span, sigexp, tyvarseq, longtycon, ty, andType)) + | doSigExp _ (S.SigIdExp (_, _)) = () + | doSigExp ctx (S.TypeRealisationExp (span, _, tyvarseq, _, ty, andType)) = ( if andType andalso not (#allowWhereAndType (#languageOptions ctx)) then emitError (ctx, [span], "'and type' is removed in Successor ML; use nested 'where type'") else @@ -1457,13 +1450,13 @@ and doSigExp ctx (S.BasicSigExp (span, specs)) = doSpecs ctx (span, specs) ; doTy ctx ty ) -fun doStrExp ctx (S.StructExp (span, strdecs)) = List.app (doStrDec ctx) strdecs - | doStrExp ctx (S.StrIdExp (span, longstrid)) = () - | doStrExp ctx (S.TransparentConstraintExp (span, strexp, sigexp)) = ( doSigExp ctx sigexp ; doStrExp ctx strexp ) - | doStrExp ctx (S.OpaqueConstraintExp (span, strexp, sigexp)) = ( doSigExp ctx sigexp ; doStrExp ctx strexp ) - | doStrExp ctx (S.FunctorAppExp (span, funid, strexp)) = doStrExp ctx strexp - | doStrExp ctx (S.LetInStrExp (span, strdecs, strexp)) = ( List.app (doStrDec ctx) strdecs ; doStrExp ctx strexp ) -and doStrDec ctx (S.CoreDec (span, dec)) = doDec (ctx, S.TyVarSet.empty) dec +fun doStrExp ctx (S.StructExp (_, strdecs)) = List.app (doStrDec ctx) strdecs + | doStrExp _ (S.StrIdExp (_, _)) = () + | doStrExp ctx (S.TransparentConstraintExp (_, strexp, sigexp)) = ( doSigExp ctx sigexp ; doStrExp ctx strexp ) + | doStrExp ctx (S.OpaqueConstraintExp (_, strexp, sigexp)) = ( doSigExp ctx sigexp ; doStrExp ctx strexp ) + | doStrExp ctx (S.FunctorAppExp (_, _, strexp)) = doStrExp ctx strexp + | doStrExp ctx (S.LetInStrExp (_, strdecs, strexp)) = ( List.app (doStrDec ctx) strdecs ; doStrExp ctx strexp ) +and doStrDec ctx (S.CoreDec (_, dec)) = doDec (ctx, S.TyVarSet.empty) dec | doStrDec ctx (S.StrBindDec (span, strbinds)) = ignore (List.foldl (fn ((strid, strexp), set) => ( doStrExp ctx strexp ; if Syntax.StrIdSet.member (set, strid) then @@ -1473,9 +1466,9 @@ and doStrDec ctx (S.CoreDec (span, dec)) = doDec (ctx, S.TyVarSet.empty) dec ; Syntax.StrIdSet.add (set, strid) ) ) Syntax.StrIdSet.empty strbinds) - | doStrDec ctx (S.LocalStrDec (span, strdecs1, strdecs2)) = ( List.app (doStrDec ctx) strdecs1 ; List.app (doStrDec ctx) strdecs2 ) + | doStrDec ctx (S.LocalStrDec (_, strdecs1, strdecs2)) = ( List.app (doStrDec ctx) strdecs1 ; List.app (doStrDec ctx) strdecs2 ) -fun doFunExp ctx (S.NamedFunExp (strid, sigexp, strexp)) = ( doSigExp ctx sigexp ; doStrExp ctx strexp ) +fun doFunExp ctx (S.NamedFunExp (_, sigexp, strexp)) = ( doSigExp ctx sigexp ; doStrExp ctx strexp ) | doFunExp ctx (S.AnonymousFunExp (sigexp, strexp)) = ( doSigExp ctx sigexp ; doStrExp ctx strexp ) fun doTopDec ctx (S.StrDec strdec) = doStrDec ctx strdec @@ -1488,7 +1481,7 @@ fun doTopDec ctx (S.StrDec strdec) = doStrDec ctx strdec ; Syntax.SigIdSet.add (set, sigid) ) ) Syntax.SigIdSet.empty sigbinds) - | doTopDec ctx (S.FunDec funbinds) = ignore (List.foldl (fn ((span, funid, funexp), set) => + | doTopDec ctx (S.FunDec funbinds) = ignore (List.foldl (fn ((_, funid, funexp), set) => ( doFunExp ctx funexp ; if Syntax.FunIdSet.member (set, funid) then emitError (ctx, [], "duplicate functor binding") (* TODO: location info *) diff --git a/src/printer.sml b/src/printer.sml index 33fdd1f9..e010786c 100644 --- a/src/printer.sml +++ b/src/printer.sml @@ -23,15 +23,15 @@ datatype fragment = Fragment of string | LineTerminator fun showParen true x = Fragment "(" :: x @ [ Fragment ")" ] | showParen false x = x -fun processIndent (indent, []) = [] +fun processIndent (_, []) = [] | processIndent (indent, Fragment s :: xs) = s :: processIndent (indent, xs) | processIndent (indent, IncreaseIndent n :: xs) = processIndent (indent + n, xs) | processIndent (indent, DecreaseIndent n :: xs) = processIndent (indent - n, xs) | processIndent (indent, Indent :: xs) = CharVector.tabulate (indent, fn _ => #" ") :: processIndent (indent, xs) | processIndent (indent, LineTerminator :: xs) = "\n" :: processIndent (indent, xs) fun build xs = String.concat (processIndent (0, xs)) -fun sepBy sep [] = [] - | sepBy sep [x] = x +fun sepBy _ [] = [] + | sepBy _ [x] = x | sepBy sep (x :: xs) = x @ sep @ sepBy sep xs val commaSep = sepBy [Fragment ", "] fun commaSepV xs = commaSep (Vector.foldr (op ::) [] xs) diff --git a/src/strongly-connected-components.sml b/src/strongly-connected-components.sml index 01d429f6..8d1dfbf6 100644 --- a/src/strongly-connected-components.sml +++ b/src/strongly-connected-components.sml @@ -36,7 +36,7 @@ fun components (destinations, graph) end val list : t list = Map.foldli (fn (x, _, acc) => acc @ dfs1 (NONE, x)) [] map fun dfs2 (x : t) : Set.set - = let val { refs, invrefs = ref invrefs, seen2, ... } = Map.lookup (map, x) + = let val { refs = _, invrefs = ref invrefs, seen2, ... } = Map.lookup (map, x) in if !seen2 then Set.empty else diff --git a/src/syntax.grm b/src/syntax.grm index 11b3a30a..30d75eba 100644 --- a/src/syntax.grm +++ b/src/syntax.grm @@ -5,12 +5,8 @@ fun nilPat span = UnfixedSyntax.NonInfixVIdPat (span, Syntax.MkLongVId (nil, Syntax.MkVId ("nil"))) fun trueExp span = UnfixedSyntax.NonInfixVIdExp (span, Syntax.MkLongVId (nil, Syntax.MkVId ("true"))) fun falseExp span = UnfixedSyntax.NonInfixVIdExp (span, Syntax.MkLongVId (nil, Syntax.MkVId ("false"))) -fun nilExp span = UnfixedSyntax.NonInfixVIdExp (span, Syntax.MkLongVId (nil, Syntax.MkVId ("nil"))) -fun consOp span = UnfixedSyntax.NonInfixVIdExp (span, Syntax.MkLongVId (nil, Syntax.MkVId ("::"))) fun MkAndAlsoExp (span,e1,e2) = UnfixedSyntax.IfThenElseExp (span, e1, e2, falseExp span) fun MkOrElseExp (span,e1,e2) = UnfixedSyntax.IfThenElseExp (span, e1, trueExp span, e2) -fun MkPairExp (span,e1,e2) = UnfixedSyntax.RecordExp (span, [UnfixedSyntax.Field (Syntax.NumericLabel 1, e1, false), UnfixedSyntax.Field (Syntax.NumericLabel 2, e2, false)]) -fun MkConsExp (span,e1,e2) = UnfixedSyntax.AppExp (span, consOp span, MkPairExp (span, e1,e2)) fun MkListExp (span, xs) = UnfixedSyntax.ListExp(span, Vector.fromList xs) fun MkVectorExp (span, xs) = UnfixedSyntax.VectorExp(span, Vector.fromList xs) fun MkPairPat (span, p1, p2) = UnfixedSyntax.TuplePat(span, [p1, p2]) @@ -23,11 +19,10 @@ fun MkSequentialExp (span, x, xs, optSemi) = let fun go (final, [], acc) = Unfix in go (x, xs, []) end fun MkTupleTy(_,[x]) = x - | MkTupleTy(span, xs) = let fun doFields i nil = nil - | doFields i (t :: ts) = (Syntax.NumericLabel i, t) :: doFields (i + 1) ts - in Syntax.RecordType (span, doFields 1 xs, NONE) - end -fun prependStrId(strid, Syntax.MkQualified(strids, x)) = Syntax.MkQualified(strid :: strids, x) + | MkTupleTy (span, xs) = let fun doFields _ nil = nil + | doFields i (t :: ts) = (Syntax.NumericLabel i, t) :: doFields (i + 1) ts + in Syntax.RecordType (span, doFields 1 xs, NONE) + end fun span(p1,p2) = { start = p1, end_ = p2 } %% @@ -104,7 +99,6 @@ fun span(p1,p2) = { start = p1, end_ = p2 } | PatPun of Syntax.Label * UnfixedSyntax.Pat * bool | PatRow of (UnfixedSyntax.Pat UnfixedSyntax.RecordItem) list | PatRowRest of (UnfixedSyntax.Pat UnfixedSyntax.RecordItem) list - | AppOrInfPat of UnfixedSyntax.Pat list | TypedPat of UnfixedSyntax.Pat | Pat of UnfixedSyntax.Pat | PatSeqRest of UnfixedSyntax.Pat list @@ -112,7 +106,6 @@ fun span(p1,p2) = { start = p1, end_ = p2 } | AtTy of Syntax.Ty | ConTy of Syntax.Ty | TupTy of Syntax.Ty list - | Ty_NoARROW of Syntax.Ty | Ty of Syntax.Ty | ConTy_NoFROM of Syntax.Ty | TupTy_NoFROM of Syntax.Ty list @@ -140,7 +133,6 @@ fun span(p1,p2) = { start = p1, end_ = p2 } | HeadExp of UnfixedSyntax.Exp | HeadExp_NoMatch of UnfixedSyntax.Exp | MatchClauses of (UnfixedSyntax.Pat * UnfixedSyntax.Exp) list - | MRule of UnfixedSyntax.Pat * UnfixedSyntax.Exp | ValDescInComment of (SourcePos.span * Syntax.VId * Syntax.Ty) list | ValDescInCommentVal of (SourcePos.span * Syntax.VId * Syntax.Ty) list | ValDescInCommentVals of (SourcePos.span * Syntax.VId * Syntax.Ty) list diff --git a/src/syntax.sml b/src/syntax.sml index ad089317..9bc84288 100644 --- a/src/syntax.sml +++ b/src/syntax.sml @@ -507,9 +507,8 @@ datatype 'coreDec TopDec = StrDec of 'coreDec StrDec type Program = ((Dec TopDec) list) list -fun SimpleVarExp(span, vid) = VarExp (span, MkLongVId ([], vid)) local - fun doFields i nil = nil + fun doFields _ nil = nil | doFields i (x :: xs) = (NumericLabel i, x) :: doFields (i + 1) xs in fun TupleExp(span, xs) = RecordExp (span, doFields 1 xs, NONE) @@ -550,7 +549,7 @@ fun MkInfixExp (exp1, vspan, longvid, exp2) = let val span = SourcePos.mergeSpan end (*: val extractTuple : int * (Label * 'a) list -> ('a list) option *) -fun extractTuple (i, nil) = SOME nil +fun extractTuple (_, nil) = SOME nil | extractTuple (i, (NumericLabel j,e) :: xs) = if i = j then case extractTuple (i + 1, xs) of NONE => NONE @@ -566,7 +565,7 @@ fun ('a,'b) mapRecordRow (f : 'a -> 'b) (row : (Label * 'a) list) = List.map (fn structure PrettyPrint = struct fun print_list p xs = "[" ^ String.concatWith "," (map p xs) ^ "]" fun print_option p (SOME x) = "SOME(" ^ p x ^ ")" - | print_option p NONE = "NONE" + | print_option _ NONE = "NONE" fun print_pair (f,g) (x,y) = "(" ^ f x ^ "," ^ g y ^ ")" fun print_SCon (IntegerConstant x) = "IntegerConstant " ^ IntInf.toString x @@ -634,10 +633,10 @@ and print_Dec (ValDec (_, bound, _, valbind)) = "ValDec(" ^ print_list print_TyV | print_Dec (RecValDec (_, bound, _, valbind)) = "RecValDec(" ^ print_list print_TyVar bound ^ "," ^ print_list print_ValBind valbind ^ ")" | print_Dec _ = "" and print_ValBind (PatBind (_,pat, exp)) = "PatBind(" ^ print_Pat pat ^ "," ^ print_Exp exp ^ ")" -val print_Decs = print_list print_Dec -fun print_VIdMap print_elem x = print_list (print_pair (print_VId,print_elem)) (VIdMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) -fun print_TyConMap print_elem x = print_list (print_pair (print_TyCon,print_elem)) (TyConMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) -fun print_StrIdMap print_elem x = print_list (print_pair (print_StrId,print_elem)) (StrIdMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) +(* val print_Decs = print_list print_Dec *) +(* fun print_VIdMap print_elem x = print_list (print_pair (print_VId,print_elem)) (VIdMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) *) +(* fun print_TyConMap print_elem x = print_list (print_pair (print_TyCon,print_elem)) (TyConMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) *) +(* fun print_StrIdMap print_elem x = print_list (print_pair (print_StrId,print_elem)) (StrIdMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) *) end open PrettyPrint @@ -771,7 +770,7 @@ datatype Exp = SConExp of SourcePos.span * Syntax.SCon (* special constant *) type Program = ((Dec Syntax.TopDec) list) list local - fun doFields i nil = nil + fun doFields _ nil = nil | doFields i (x :: xs) = Field (Syntax.NumericLabel i, x, false) :: doFields (i + 1) xs in fun TupleExp(span, xs) = RecordExp (span, doFields 1 xs) diff --git a/src/tokenizer.sml b/src/tokenizer.sml index 85ff1225..0354bf00 100644 --- a/src/tokenizer.sml +++ b/src/tokenizer.sml @@ -16,7 +16,7 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig type pos = SourcePos.pos (* line, column; both 1-based *) type svalue = Tokens.svalue type ('a,'b) token = ('a,'b) Tokens.token - type result = (svalue,pos) token + (* type result = (svalue,pos) token *) type arg = (* filename *) string * LanguageOptions.options * Message.handler end datatype NumericLitType = NLTUnsigned @@ -150,12 +150,12 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig else skipComment (state, l0, c0, l + 1, 1, n - 1, xs) | skipLineComment (state, l0, c0, l, n, _ :: xs) = skipLineComment (state, l0, c0, l, n, xs) - | skipLineComment (state, l0, c0, l, n, nil) = ( if n <> 0 then - emitError (l0, c0, "unterminated comment") - else - () - ; NONE - ) + | skipLineComment (_, l0, c0, _, n, nil) = ( if n <> 0 then + emitError (l0, c0, "unterminated comment") + else + () + ; NONE + ) and skipComment (state, l0, c0, l, c, n, #"*" :: #")" :: xs) = if n = 0 then tokenizeOne (state, l, c + 2, xs) else @@ -165,11 +165,11 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig else skipComment (state, l0, c0, l, c + 3, n + 1, xs) | skipComment (state, l0, c0, l, c, n, #"(" :: #"*" :: xs) = skipComment (state, l0, c0, l, c + 2, n + 1, xs) - | skipComment (state, l0, c0, l, c, n, #"\n" :: xs) = skipComment (state, l0, c0, l + 1, 1, n, xs) + | skipComment (state, l0, c0, l, _, n, #"\n" :: xs) = skipComment (state, l0, c0, l + 1, 1, n, xs) | skipComment (state, l0, c0, l, c, n, _ :: xs) = skipComment (state, l0, c0, l, c + 1, n, xs) - | skipComment (state, l0, c0, _, _, _, nil) = ( emitError (l0, c0, "unterminated comment") - ; NONE - ) + | skipComment (_, l0, c0, _, _, _, nil) = ( emitError (l0, c0, "unterminated comment") + ; NONE + ) and readIdentifierOrKeyword (state, l, c0, c1, startingDot, rstrids, accum, nil) = let val name = String.implode (List.rev accum) val (tok, ident) = recognizeKeyword (l, c1, name) @@ -210,7 +210,7 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig val (tok, ident) = recognizeKeyword (l, c1, name) in if List.null rstrids then case ident of - SOME (name, p2) => + SOME (name, _) => if x = #"." then let fun finalize () = if startingDot then let val p1 = pos (l, c0) @@ -374,14 +374,29 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig val p2 = pos(l,c + String.size name - 1) in (tok (pos(l, c), p2), Option.map (fn name => (name, p2)) ident) end - and readSymbolicIdentifier (state, l, c0, c1, startingDot, rstrids, accum, nil) = let val (tok, ident) = recognizeSymbolic (l, c1, String.implode (rev accum)) - in if startingDot then - case ident of - SOME (name, p2) => SOME (Tokens.DotSymbolicIdent (name, pos (l, c0), p2), state, l, c1 + length accum, nil) - | _ => ( emitError (l, c0, "stray dot"); SOME (tok, state, l, c1 + length accum, nil) ) - else - SOME (tok, state, l, c1 + length accum, nil) - end + and readSymbolicIdentifier (state, l, c0, c1, startingDot, rstrids, accum, input as nil) = let val (tok, ident) = recognizeSymbolic (l, c1, String.implode (rev accum)) + in if List.null rstrids then + if startingDot then + case ident of + SOME (name, p2) => SOME (Tokens.DotSymbolicIdent (name, pos (l, c0), p2), state, l, c1 + length accum, input) + | _ => ( emitError (l, c0, "stray dot"); SOME (tok, state, l, c1 + length accum, input) ) + else + SOME (tok, state, l, c1 + length accum, input) + else + ( if startingDot then + emitError (l, c0, "stray dot") + else + () + ; case ident of + SOME (name, p2) => (case List.rev rstrids of + strids as "_Prim" :: _ => SOME (Tokens.PrimIdent (String.concatWith "." (strids @ [name]), pos (l, c0), p2), state, l, c1 + length accum, input) + | strids => SOME (Tokens.QualifiedSymbolicIdent ((strids, name), pos (l, c0), p2), state, l, c1 + length accum, input) + ) + | NONE => ( emitError (l, c1, "invalid qualified name") + ; SOME (tok, state, l, c1 + length accum, input) + ) + ) + end | readSymbolicIdentifier (state, l, c0, c1, startingDot, rstrids, accum, input as x :: xs) = if isSymbolChar x then readSymbolicIdentifier (state, l, c0, c1, startingDot, rstrids, x :: accum, xs) @@ -389,23 +404,23 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig let val (tok, ident) = recognizeSymbolic (l, c1, String.implode (rev accum)) in if List.null rstrids then case ident of - SOME (name, p2) => ( if #allowInfixingDot opts then - () - else - emitError (l, c0, "stray dot; set \"allowInfixingDot true\" to enable infix identifiers") - ; SOME (Tokens.InfixIdent (name, pos (l, c0), pos (l, c1 + String.size name)), state, l, c1 + length accum, xs) - ) + SOME (name, _) => ( if #allowInfixingDot opts then + () + else + emitError (l, c0, "stray dot; set \"allowInfixingDot true\" to enable infix identifiers") + ; SOME (Tokens.InfixIdent (name, pos (l, c0), pos (l, c1 + String.size name)), state, l, c1 + length accum, xs) + ) | _ => ( emitError (l, c0, "stray dot"); SOME (tok, state, l, c1 + length accum, input) ) else case ident of - SOME (name, p2) => ( if #allowInfixingDot opts then - () - else - emitError (l, c0, "stray dot; set \"allowInfixingDot true\" to enable infix identifiers") - ; case List.rev rstrids of - strids as "_Prim" :: _ => SOME (Tokens.InfixIdent (String.concatWith "." (strids @ [name]), pos (l, c0), pos (l, c1 + String.size name)), state, l, c1 + length accum, xs) - | strids => SOME (Tokens.QualifiedInfixIdent ((strids, name), pos (l, c0), pos (l, c1 + String.size name)), state, l, c1 + length accum, xs) - ) + SOME (name, _) => ( if #allowInfixingDot opts then + () + else + emitError (l, c0, "stray dot; set \"allowInfixingDot true\" to enable infix identifiers") + ; case List.rev rstrids of + strids as "_Prim" :: _ => SOME (Tokens.InfixIdent (String.concatWith "." (strids @ [name]), pos (l, c0), pos (l, c1 + String.size name)), state, l, c1 + length accum, xs) + | strids => SOME (Tokens.QualifiedInfixIdent ((strids, name), pos (l, c0), pos (l, c1 + String.size name)), state, l, c1 + length accum, xs) + ) | NONE => ( emitError (l, c0, "stray dot") ; emitError (l, c1, "invalid qualified name") ; SOME (tok, state, l, c1 + length accum, input) @@ -477,7 +492,7 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig SOME (anyUnderscores, c + 1, x, xs) else NONE - | skipUnderscoresAndReadDigit (_, c, []) = NONE + | skipUnderscoresAndReadDigit (_, _, []) = NONE and skipUnderscoresAndReadHexDigit (c, #"_" :: xs) = if #allowExtendedNumConsts opts then skipUnderscoresAndReadHexDigit (c + 1, xs) (* [Successor ML] extended literal syntax (underscore) *) else @@ -486,13 +501,13 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig SOME (c + 1, x, xs) else NONE - | skipUnderscoresAndReadHexDigit (c, []) = NONE + | skipUnderscoresAndReadHexDigit (_, []) = NONE and skipUnderscoresAndReadBinaryDigit (c, #"_" :: xs) = skipUnderscoresAndReadBinaryDigit (c + 1, xs) (* [Successor ML] extended literal syntax (underscore) *) | skipUnderscoresAndReadBinaryDigit (c, x :: xs) = if isBinDigit x then SOME (c + 1, x, xs) else NONE - | skipUnderscoresAndReadBinaryDigit (c, []) = NONE + | skipUnderscoresAndReadBinaryDigit (_, []) = NONE and readDecimalConstant (state, l1, c1, c', numericLitType : NumericLitType, x0 : IntInf.int, xs : char list) (* x0 is a decimal digit *) = let fun mkIntConst (anyUnderscores, p2, a) = if numericLitType = NLTWord then @@ -647,7 +662,7 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig ( emitError (l, c, "malformed number: fractional part must not be empty") ; (c + 1, SOME (vector []), xs) ) - | parseFracPart (l, c, xs) = (c, NONE, xs) + | parseFracPart (_, c, xs) = (c, NONE, xs) and parseMoreFracPart (c, revAcc, xs) = (case skipUnderscoresAndReadHexDigit (c, xs) of SOME (c', x, xss) => parseMoreFracPart (c', hexDigitToInt x :: revAcc, xss) @@ -692,7 +707,7 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig and readStringLit (l0, c0, l, c, accum, nil) = ( emitError (l0, c0, "unterminated string literal") ; (l, c, rev accum, nil) ) - | readStringLit (l0, c0, l, c, accum, #"\"" :: xs) = (l, c+1, rev accum, xs) + | readStringLit (_, _, l, c, accum, #"\"" :: xs) = (l, c + 1, rev accum, xs) | readStringLit (l0, c0, l, c, accum, #"\\" :: #"a" :: xs) = readStringLit (l0, c0, l, c + 2, StringElement.CODEUNIT (ord #"\a") :: accum, xs) (* bell *) | readStringLit (l0, c0, l, c, accum, #"\\" :: #"b" :: xs) = readStringLit (l0, c0, l, c + 2, StringElement.CODEUNIT (ord #"\b") :: accum, xs) (* backspace *) | readStringLit (l0, c0, l, c, accum, #"\\" :: #"t" :: xs) = readStringLit (l0, c0, l, c + 2, StringElement.CODEUNIT (ord #"\t") :: accum, xs) (* horizontal tab *) @@ -729,7 +744,7 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig ( emitError (l, c, "invalid \\u{} escape sequence") ; readStringLit (l0, c0, l, c, accum, y :: ys) ) - | go (c, scalar, ys as []) = readStringLit (l0, c0, l, c, accum, ys) (* unterminated string literal *) + | go (c, _, ys as []) = readStringLit (l0, c0, l, c, accum, ys) (* unterminated string literal *) in if Char.isHexDigit x0 then go (c1 + 4, hexDigitToInt x0, xs) else @@ -797,7 +812,7 @@ functor LunarMLLexFun (structure Tokens: LunarML_TOKENS) : sig ; (l, c, rev accum, nil) ) | skipFormattingCharacters (l0, c0, l, c, accum, #"\\" :: xs) = readStringLit (l0, c0, l, c+1, accum, xs) - | skipFormattingCharacters (l0, c0, l, c, accum, #"\n" :: xs) = skipFormattingCharacters(l0, c0, l+1, 1, accum, xs) + | skipFormattingCharacters (l0, c0, l, _, accum, #"\n" :: xs) = skipFormattingCharacters (l0, c0, l+1, 1, accum, xs) | skipFormattingCharacters (l0, c0, l, c, accum, x :: xs) = if Char.isSpace x then skipFormattingCharacters (l0, c0, l, c+1, accum, xs) else diff --git a/src/typed.sml b/src/typed.sml index 4a8bf950..b43f8b5a 100644 --- a/src/typed.sml +++ b/src/typed.sml @@ -190,9 +190,6 @@ datatype LongStrId = MkLongStrId of StrId * Syntax.StrId list fun eqUTyVar (MkTyVar (name, a), MkTyVar (name', b)) = name = name' andalso a = b fun eqTyName(MkTyName(_,a),MkTyName(_,b)) = a = b fun eqVId(a, b : VId) = a = b -fun eqULongVId(MkShortVId a, MkShortVId b) = eqVId(a, b) - | eqULongVId(MkLongVId(s, t, u), MkLongVId(s', t', u')) = s = s' andalso t = t' andalso u = u' - | eqULongVId(_, _) = false fun tyVarAdmitsEquality (MkTyVar (name, _)) = String.isPrefix "''" name @@ -239,23 +236,8 @@ fun compare(MkStrId(x,a), MkStrId(y,b)) = case String.compare (x,y) of EQUAL => Int.compare(a,b) | ord => ord end : ORD_KEY -structure StrIdSet = RedBlackSetFn(StrIdKey) -structure StrIdMap = RedBlackMapFn(StrIdKey) - -structure LongVIdKey = struct -type ord_key = LongVId -fun compare(MkShortVId(vid), MkShortVId(vid')) = VIdKey.compare(vid, vid') - | compare(MkShortVId _, MkLongVId _) = LESS - | compare(MkLongVId _, MkShortVId _) = GREATER - | compare(MkLongVId(strid0, strids, vid), MkLongVId(strid0', strids', vid')) = case StrIdKey.compare(strid0, strid0') of - EQUAL => (case Syntax.VIdKey.compare(vid, vid') of - EQUAL => List.collate Syntax.StrIdKey.compare (strids, strids') - | x => x - ) - | x => x -end : ORD_KEY -structure LongVIdSet = RedBlackSetFn(LongVIdKey) -structure LongVIdMap = RedBlackMapFn(LongVIdKey) +(* structure StrIdSet = RedBlackSetFn(StrIdKey) *) +(* structure StrIdMap = RedBlackMapFn(StrIdKey) *) type level = int @@ -285,10 +267,6 @@ datatype Ty = TyVar of SourcePos.span * TyVar (* named type variable *) type AnonymousTyVar = TyVarData ref fun PairType (span, a, b) = RecordType (span, Syntax.LabelMapFromList [(Syntax.NumericLabel 1, a), (Syntax.NumericLabel 2, b)]) -fun TupleType (span, xs) = let fun doFields (i, nil, m) = m - | doFields (i, x :: xs, m) = doFields (i + 1, xs, Syntax.LabelMap.insert (m, Syntax.NumericLabel i, x)) - in RecordType (span, doFields (1, xs, Syntax.LabelMap.empty)) - end datatype Constraint = EqConstr of SourcePos.span * Ty * Ty (* ty1 = ty2 *) @@ -401,7 +379,7 @@ type Program = (TopDec list) list fun TupleType(span, xs) = RecordType (span, #2 (List.foldl (fn (ty, (i, m)) => (i+1, Syntax.LabelMap.insert (m, Syntax.NumericLabel i, ty))) (1, Syntax.LabelMap.empty) xs)) local - fun doFields i nil = nil + fun doFields _ nil = nil | doFields i (x :: xs) = (Syntax.NumericLabel i, x) :: doFields (i + 1) xs in fun TupleExp(span, xs) = RecordExp (span, doFields 1 xs) @@ -485,13 +463,13 @@ fun print_Pat (WildcardPat _) = "WildcardPat" | print_Pat (RecordPat{fields = x, ellipsis = SOME basePat, ...}) = "RecordPat(" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_Label, print_Pat)) x ^ ",SOME(" ^ print_Pat basePat ^ "))" | print_Pat (VectorPat _) = "VectorPat" (* | print_Pat _ = "" *) -fun print_Exp (SConExp(_, x, ty)) = "SConExp(" ^ Syntax.print_SCon x ^ ")" +fun print_Exp (SConExp (_, x, _)) = "SConExp(" ^ Syntax.print_SCon x ^ ")" | print_Exp (VarExp(_, x, idstatus, tyargs)) = "VarExp(" ^ print_LongVId x ^ "," ^ Syntax.print_IdStatus idstatus ^ "," ^ Syntax.print_list (Syntax.print_pair (print_Ty, Syntax.print_list print_UnaryConstraint)) tyargs ^ ")" | print_Exp (RecordExp(_, x)) = (case Syntax.extractTuple (1, x) of NONE => "RecordExp " ^ Syntax.print_list (Syntax.print_pair (Syntax.print_Label, print_Exp)) x | SOME ys => "TupleExp " ^ Syntax.print_list print_Exp ys ) - | print_Exp (RecordExtExp { sourceSpan = _, fields, baseExp, baseTy }) = "RecordExtExp(" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_Label, print_Exp)) fields ^ "," ^ print_Exp baseExp ^ ")" + | print_Exp (RecordExtExp { sourceSpan = _, fields, baseExp, baseTy = _ }) = "RecordExtExp(" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_Label, print_Exp)) fields ^ "," ^ print_Exp baseExp ^ ")" | print_Exp (LetInExp(_,decls,x)) = "LetInExp(" ^ Syntax.print_list print_Dec decls ^ "," ^ print_Exp x ^ ")" | print_Exp (AppExp(_,x,y)) = "AppExp(" ^ print_Exp x ^ "," ^ print_Exp y ^ ")" | print_Exp (TypedExp(_,x,y)) = "TypedExp(" ^ print_Exp x ^ "," ^ print_Ty y ^ ")" @@ -510,7 +488,7 @@ and print_Dec (ValDec(_,valbinds)) = "ValDec(" ^ Syntax.print_list print_ValBind | print_Dec (IgnoreDec _) = "IgnoreDec" | print_Dec (TypeDec(_, typbinds)) = "TypeDec(" ^ Syntax.print_list print_TypBind typbinds ^ ")" | print_Dec (DatatypeDec(_, datbinds)) = "DatatypeDec(" ^ Syntax.print_list print_DatBind datbinds ^ ")" - | print_Dec (ExceptionDec(_, exbinds)) = "ExceptionDec" + | print_Dec (ExceptionDec (_, _)) = "ExceptionDec" | print_Dec (OverloadDec _) = "OverloadDec" | print_Dec (EqualityDec _) = "EqualityDec" | print_Dec (ValDescDec _) = "ValDescDec" @@ -521,8 +499,8 @@ and print_ConBind (ConBind(_, vid, NONE, _)) = "ConBind(" ^ print_VId vid ^ ",NO | print_ConBind (ConBind(_, vid, SOME ty, _)) = "ConBind(" ^ print_VId vid ^ ",SOME " ^ print_Ty ty ^ ")" and print_ValBind (TupleBind (_, xs, exp)) = "TupleBind(" ^ Syntax.print_list (Syntax.print_pair (print_VId, print_Ty)) xs ^ "," ^ print_Exp exp ^ ")" | print_ValBind (PolyVarBind (_, name, tysc, exp)) = "PolyVarBind(" ^ print_VId name ^ "," ^ print_TypeScheme tysc ^ "," ^ print_Exp exp ^ ")" -and print_TyVarMap print_elem x = Syntax.print_list (Syntax.print_pair (print_TyVar,print_elem)) (TyVarMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) -and print_VIdMap print_elem x = Syntax.print_list (Syntax.print_pair (print_VId,print_elem)) (VIdMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) +(* and print_TyVarMap print_elem x = Syntax.print_list (Syntax.print_pair (print_TyVar,print_elem)) (TyVarMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) *) +(* and print_VIdMap print_elem x = Syntax.print_list (Syntax.print_pair (print_VId,print_elem)) (VIdMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) *) and print_UnaryConstraint (NoField label) = "NoField(" ^ Syntax.print_Label label ^ ")" | print_UnaryConstraint IsRecord = "IsEqType" | print_UnaryConstraint IsEqType = "IsEqType" @@ -536,24 +514,24 @@ and print_UnaryConstraint (NoField label) = "NoField(" ^ Syntax.print_Label labe | print_UnaryConstraint IsChar = "IsChar" | print_UnaryConstraint IsString = "IsString" and print_TypeScheme (TypeScheme(tyvars, ty)) = "TypeScheme(" ^ Syntax.print_list (Syntax.print_pair (print_TyVar, Syntax.print_list print_UnaryConstraint)) tyvars ^ "," ^ print_Ty ty ^ ")" -and print_ValEnv env = print_VIdMap (Syntax.print_pair (print_TypeScheme,Syntax.print_IdStatus)) env -fun print_TyVarSet x = Syntax.print_list print_TyVar (TyVarSet.foldr (fn (x,ys) => x :: ys) [] x) -fun print_TyNameMap print_elem x = Syntax.print_list (Syntax.print_pair (print_TyName,print_elem)) (TyNameMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) +(* and print_ValEnv env = print_VIdMap (Syntax.print_pair (print_TypeScheme,Syntax.print_IdStatus)) env *) +(* fun print_TyVarSet x = Syntax.print_list print_TyVar (TyVarSet.foldr (fn (x,ys) => x :: ys) [] x) *) +(* fun print_TyNameMap print_elem x = Syntax.print_list (Syntax.print_pair (print_TyName,print_elem)) (TyNameMap.foldri (fn (k,x,ys) => (k,x) :: ys) [] x) *) fun print_TypeFunction (TypeFunction (tyvars, ty)) = "TypeFunction(" ^ Syntax.print_list print_TyVar tyvars ^ "," ^ print_Ty ty ^ ")" -val print_Decs = Syntax.print_list print_Dec -fun print_Constraint(EqConstr(span,ty1,ty2)) = "EqConstr(" ^ print_Ty ty1 ^ "," ^ print_Ty ty2 ^ ")" - | print_Constraint(UnaryConstraint(span,ty,ct)) = "Unary(" ^ print_Ty ty ^ "," ^ print_UnaryConstraint ct ^ ")" -fun print_Signature { valMap, tyConMap, strMap } = "{valMap=" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_VId, Syntax.print_pair (print_TypeScheme, Syntax.print_IdStatus))) (Syntax.VIdMap.listItemsi valMap) ^ ",tyConMap=..." ^ ",strMap=..." ^ "}" +(* val print_Decs = Syntax.print_list print_Dec *) +(* fun print_Constraint(EqConstr(span,ty1,ty2)) = "EqConstr(" ^ print_Ty ty1 ^ "," ^ print_Ty ty2 ^ ")" + | print_Constraint(UnaryConstraint(span,ty,ct)) = "Unary(" ^ print_Ty ty ^ "," ^ print_UnaryConstraint ct ^ ")" *) +fun print_Signature { valMap, tyConMap = _, strMap = _ } = "{valMap=" ^ Syntax.print_list (Syntax.print_pair (Syntax.print_VId, Syntax.print_pair (print_TypeScheme, Syntax.print_IdStatus))) (Syntax.VIdMap.listItemsi valMap) ^ ",tyConMap=..." ^ ",strMap=..." ^ "}" fun print_PackedSignature { s, bound } = "{s=" ^ print_Signature s ^ ",bound=" ^ Syntax.print_list (fn { tyname, arity, admitsEquality } => "(" ^ print_TyName tyname ^ "," ^ Int.toString arity ^ "," ^ Bool.toString admitsEquality ^ ")") bound ^ "}" -fun print_StrExp (StructExp { sourceSpan, valMap, tyConMap, strMap }) = "StructExp" - | print_StrExp (StrIdExp (span, longstrid)) = "StrIdExp(" ^ print_LongStrId longstrid ^ ")" - | print_StrExp (PackedStrExp { sourceSpan, strExp, payloadTypes, packageSig }) = "PackedStrExp(" ^ print_StrExp strExp ^ "," ^ Syntax.print_list print_TypeFunction payloadTypes ^ "," ^ print_PackedSignature packageSig ^ ")" - | print_StrExp (FunctorAppExp { sourceSpan, funId, argumentTypes, argumentStr, packageSig }) = "FunctorAppExp(" ^ print_FunId funId ^ "," ^ Syntax.print_list (fn { typeFunction, admitsEquality } => "(" ^ print_TypeFunction typeFunction ^ "," ^ Bool.toString admitsEquality ^ ")") argumentTypes ^ "," ^ print_StrExp argumentStr ^ "," ^ print_PackedSignature packageSig ^ ")" - | print_StrExp (LetInStrExp (span, strdecs, strexp)) = "LetInStrExp(" ^ Syntax.print_list print_StrDec strdecs ^ "," ^ print_StrExp strexp ^ ")" -and print_StrDec (CoreDec (span, dec)) = print_Dec dec - | print_StrDec (StrBindDec (span, strid, strexp, ps)) = "StrBindDec(" ^ print_StrId strid ^ "," ^ print_StrExp strexp ^ ")" -fun print_TopDec (StrDec strdec) = print_StrDec strdec - | print_TopDec (FunDec (funid, (typarams, strid, s, strexp))) = "FunDec(" ^ print_FunId funid ^ ",(" ^ Syntax.print_list (fn { tyname, arity, admitsEquality } => "(" ^ print_TyName tyname ^ "," ^ Int.toString arity ^ "," ^ Bool.toString admitsEquality ^ ")") typarams ^ "," ^ print_Signature s ^ "," ^ print_StrExp strexp ^ "))" +fun print_StrExp (StructExp { sourceSpan = _, valMap = _, tyConMap = _, strMap = _ }) = "StructExp" + | print_StrExp (StrIdExp (_, longstrid)) = "StrIdExp(" ^ print_LongStrId longstrid ^ ")" + | print_StrExp (PackedStrExp { sourceSpan = _, strExp, payloadTypes, packageSig }) = "PackedStrExp(" ^ print_StrExp strExp ^ "," ^ Syntax.print_list print_TypeFunction payloadTypes ^ "," ^ print_PackedSignature packageSig ^ ")" + | print_StrExp (FunctorAppExp { sourceSpan = _, funId, argumentTypes, argumentStr, packageSig }) = "FunctorAppExp(" ^ print_FunId funId ^ "," ^ Syntax.print_list (fn { typeFunction, admitsEquality } => "(" ^ print_TypeFunction typeFunction ^ "," ^ Bool.toString admitsEquality ^ ")") argumentTypes ^ "," ^ print_StrExp argumentStr ^ "," ^ print_PackedSignature packageSig ^ ")" + | print_StrExp (LetInStrExp (_, strdecs, strexp)) = "LetInStrExp(" ^ Syntax.print_list print_StrDec strdecs ^ "," ^ print_StrExp strexp ^ ")" +and print_StrDec (CoreDec (_, dec)) = print_Dec dec + | print_StrDec (StrBindDec (_, strid, strexp, _)) = "StrBindDec(" ^ print_StrId strid ^ "," ^ print_StrExp strexp ^ ")" +(* fun print_TopDec (StrDec strdec) = print_StrDec strdec + | print_TopDec (FunDec (funid, (typarams, strid, s, strexp))) = "FunDec(" ^ print_FunId funid ^ ",(" ^ Syntax.print_list (fn { tyname, arity, admitsEquality } => "(" ^ print_TyName tyname ^ "," ^ Int.toString arity ^ "," ^ Bool.toString admitsEquality ^ ")") typarams ^ "," ^ print_Signature s ^ "," ^ print_StrExp strexp ^ "))" *) end (* structure PrettyPrint *) open PrettyPrint @@ -671,14 +649,14 @@ fun applySubstTyInExpOrDec subst fun boundVIdsInPat (WildcardPat _) = VIdSet.empty | boundVIdsInPat (SConPat _) = VIdSet.empty - | boundVIdsInPat (VarPat (span, vid, ty)) = VIdSet.singleton vid - | boundVIdsInPat (RecordPat { sourceSpan, fields, ellipsis = NONE, wholeRecordType }) = List.foldl (fn ((label, pat), acc) => VIdSet.union (boundVIdsInPat pat, acc)) VIdSet.empty fields - | boundVIdsInPat (RecordPat { sourceSpan, fields, ellipsis = SOME base, wholeRecordType }) = List.foldl (fn ((label, pat), acc) => VIdSet.union (boundVIdsInPat pat, acc)) (boundVIdsInPat base) fields - | boundVIdsInPat (ConPat { sourceSpan, longvid, payload = NONE, tyargs, valueConstructorInfo }) = VIdSet.empty - | boundVIdsInPat (ConPat { sourceSpan, longvid, payload = SOME (ty, pat), tyargs, valueConstructorInfo }) = boundVIdsInPat pat - | boundVIdsInPat (TypedPat (span, pat, ty)) = boundVIdsInPat pat - | boundVIdsInPat (LayeredPat (span, vid, ty, pat)) = VIdSet.add (boundVIdsInPat pat, vid) - | boundVIdsInPat (VectorPat (span, pats, ellipsis, ty)) = Vector.foldl (fn (pat, acc) => VIdSet.union (boundVIdsInPat pat, acc)) VIdSet.empty pats + | boundVIdsInPat (VarPat (_, vid, _)) = VIdSet.singleton vid + | boundVIdsInPat (RecordPat { sourceSpan = _, fields, ellipsis = NONE, wholeRecordType = _ }) = List.foldl (fn ((_, pat), acc) => VIdSet.union (boundVIdsInPat pat, acc)) VIdSet.empty fields + | boundVIdsInPat (RecordPat { sourceSpan = _, fields, ellipsis = SOME base, wholeRecordType = _ }) = List.foldl (fn ((_, pat), acc) => VIdSet.union (boundVIdsInPat pat, acc)) (boundVIdsInPat base) fields + | boundVIdsInPat (ConPat { sourceSpan = _, longvid = _, payload = NONE, tyargs = _, valueConstructorInfo = _ }) = VIdSet.empty + | boundVIdsInPat (ConPat { sourceSpan = _, longvid = _, payload = SOME (_, pat), tyargs = _, valueConstructorInfo = _ }) = boundVIdsInPat pat + | boundVIdsInPat (TypedPat (_, pat, _)) = boundVIdsInPat pat + | boundVIdsInPat (LayeredPat (_, vid, _, pat)) = VIdSet.add (boundVIdsInPat pat, vid) + | boundVIdsInPat (VectorPat (_, pats, _, _)) = Vector.foldl (fn (pat, acc) => VIdSet.union (boundVIdsInPat pat, acc)) VIdSet.empty pats fun substVId (subst : (SourcePos.span * Syntax.ValueConstructorInfo Syntax.IdStatus * (Ty * UnaryConstraint list) list -> Exp) VIdMap.map) = let fun remove' (map, key) = if VIdMap.inDomain (map, key) then @@ -686,8 +664,8 @@ fun substVId (subst : (SourcePos.span * Syntax.ValueConstructorInfo Syntax.IdSta else map fun removeKeys (map, keys) = VIdSet.foldl (fn (key, map) => remove' (map, key)) map keys - fun boundVIdsInValBinds valbinds = List.foldl (fn (TupleBind (span, vids, exp), acc) => List.foldl (fn ((vid, ty), acc) => VIdSet.add (acc, vid)) acc vids - | (PolyVarBind (span, vid, tysc, exp), acc) => VIdSet.add (acc, vid)) VIdSet.empty valbinds + fun boundVIdsInValBinds valbinds = List.foldl (fn (TupleBind (_, vids, _), acc) => List.foldl (fn ((vid, _), acc) => VIdSet.add (acc, vid)) acc vids + | (PolyVarBind (_, vid, _, _), acc) => VIdSet.add (acc, vid)) VIdSet.empty valbinds fun doExp (e as SConExp _) = e | doExp (e as VarExp (span, MkShortVId vid, idstatus, tyargs)) = (case VIdMap.find (subst, vid) of NONE => e @@ -709,11 +687,11 @@ fun substVId (subst : (SourcePos.span * Syntax.ValueConstructorInfo Syntax.IdSta | doExp (FnExp (span, vid, ty, exp)) = let val subst' = remove' (subst, vid) in FnExp (span, vid, ty, #doExp (substVId subst') exp) end - | doExp (e as ProjectionExp { sourceSpan, label, recordTy, fieldTy }) = e + | doExp (e as ProjectionExp _) = e | doExp (ListExp (span, elems, elemTy)) = ListExp (span, Vector.map doExp elems, elemTy) | doExp (VectorExp (span, elems, elemTy)) = VectorExp (span, Vector.map doExp elems, elemTy) | doExp (PrimExp (span, primOp, tyargs, args)) = PrimExp (span, primOp, tyargs, Vector.map doExp args) - | doExp (e as BogusExp (span, ty)) = e + | doExp (e as BogusExp _) = e and doMatches matches = List.map (fn (pat, exp) => let val subst' = removeKeys (subst, boundVIdsInPat pat) in (pat, #doExp (substVId subst') exp) end) matches @@ -728,17 +706,17 @@ fun substVId (subst : (SourcePos.span * Syntax.ValueConstructorInfo Syntax.IdSta in (bound, RecValDec (span, valbinds')) end | doDec (IgnoreDec (span, exp, ty)) = (VIdSet.empty, IgnoreDec (span, doExp exp, ty)) - | doDec (d as TypeDec (span, typbinds)) = (VIdSet.empty, d) - | doDec (d as DatatypeDec (span, datbinds)) = (List.foldl (fn (DatBind (_, _, _, conbinds, admitsEquality), acc) => List.foldl (fn (ConBind (_, vid, _, _), acc) => VIdSet.add (acc, vid)) acc conbinds) VIdSet.empty datbinds, d) - | doDec (d as ExceptionDec (span, exbinds)) = (List.foldl (fn (ExBind (span, vid, optTy), acc) => VIdSet.add (acc, vid) - | (ExReplication (span, vid, longvid, optTy), acc) => VIdSet.add (acc, vid) (* longvid? *) - ) VIdSet.empty exbinds, d) + | doDec (d as TypeDec _) = (VIdSet.empty, d) + | doDec (d as DatatypeDec (_, datbinds)) = (List.foldl (fn (DatBind (_, _, _, conbinds, _), acc) => List.foldl (fn (ConBind (_, vid, _, _), acc) => VIdSet.add (acc, vid)) acc conbinds) VIdSet.empty datbinds, d) + | doDec (d as ExceptionDec (_, exbinds)) = (List.foldl (fn (ExBind (_, vid, _), acc) => VIdSet.add (acc, vid) + | (ExReplication (_, vid, _, _), acc) => VIdSet.add (acc, vid) (* longvid? *) + ) VIdSet.empty exbinds, d) | doDec (OverloadDec (span, class, tyname, map)) = (VIdSet.empty, OverloadDec (span, class, tyname, Syntax.OverloadKeyMap.map doExp map)) | doDec (EqualityDec (span, tyvars, tyname, exp)) = (VIdSet.empty, EqualityDec (span, tyvars, tyname, doExp exp)) | doDec (e as ValDescDec _) = (VIdSet.empty, e) - | doDec (d as ESImportDec { sourceSpan, pure, specs, moduleName }) = let val bound = List.foldl (fn ((_, vid, _), bound) => VIdSet.add (bound, vid)) VIdSet.empty specs - in (bound, d) - end + | doDec (d as ESImportDec { sourceSpan = _, pure = _, specs, moduleName = _ }) = let val bound = List.foldl (fn ((_, vid, _), bound) => VIdSet.add (bound, vid)) VIdSet.empty specs + in (bound, d) + end and doDecs decs = let val (env, decs) = List.foldl (fn (dec, (env, decs)) => let val subst' = removeKeys (subst, env) val (env', dec) = #doDec (substVId subst') dec in (VIdSet.union (env', env), dec :: decs) @@ -749,25 +727,25 @@ fun substVId (subst : (SourcePos.span * Syntax.ValueConstructorInfo Syntax.IdSta end fun forceTy (ty as TyVar _) = ty - | forceTy (ty as AnonymousTyVar (span, tv)) = (case !tv of - Unbound _ => ty - | Link value => forceTy value - ) + | forceTy (ty as AnonymousTyVar (_, tv)) = (case !tv of + Unbound _ => ty + | Link value => forceTy value + ) | forceTy (RecordType (span, fields)) = RecordType (span, Syntax.LabelMap.map forceTy fields) | forceTy (TyCon (span, tyargs, tyname)) = TyCon (span, List.map forceTy tyargs, tyname) | forceTy (FnType (span, ty1, ty2)) = FnType (span, forceTy ty1, forceTy ty2) | forceTy (RecordExtType (span, fields, baseTy)) = let val fields = Syntax.LabelMap.map forceTy fields in case forceTy baseTy of - RecordType (span', fields') => RecordType (span, Syntax.LabelMap.unionWith #2 (fields', fields)) (* duplication should be an error *) - | RecordExtType (span', fields', baseTy') => RecordExtType (span, Syntax.LabelMap.unionWith #2 (fields', fields), baseTy') (* duplication should be an error *) + RecordType (_, fields') => RecordType (span, Syntax.LabelMap.unionWith #2 (fields', fields)) (* duplication should be an error *) + | RecordExtType (_, fields', baseTy') => RecordExtType (span, Syntax.LabelMap.unionWith #2 (fields', fields), baseTy') (* duplication should be an error *) | baseTy' => RecordExtType (span, fields, baseTy') (* ill-kinded *) end (*: val forceTyIn : { nextTyVar : int ref, nextVId : 'a, matchContext : 'b, messageHandler : 'c, languageOptions : 'd } -> { doExp : Exp -> Exp, doDec : Dec -> Dec, doDecs : Dec list -> Dec list, doTopDec : TopDec -> TopDec, doTopDecs : TopDec list -> TopDec list } *) -fun forceTyIn (ctx : { nextTyVar : int ref, nextVId : 'a, matchContext : 'b, messageHandler : 'c, languageOptions : 'd }) +fun forceTyIn (_ : { nextTyVar : int ref, nextVId : 'a, matchContext : 'b, messageHandler : 'c, languageOptions : 'd }) = let val doTy = forceTy fun doTypeScheme (TypeScheme (tyvarsWithConstraints, ty)) = TypeScheme (tyvarsWithConstraints, doTy ty) - val doValEnv = VIdMap.map (fn (tysc, idstatus) => (doTypeScheme tysc, idstatus)) + (* val doValEnv = VIdMap.map (fn (tysc, idstatus) => (doTypeScheme tysc, idstatus)) *) fun doExp(SConExp(span, scon, ty)) = SConExp(span, scon, doTy ty) | doExp (VarExp (span, longvid, idstatus, tyargs)) = VarExp (span, longvid, idstatus, List.map (fn (ty, cts) => (doTy ty, cts)) tyargs) | doExp(RecordExp(span, fields)) = RecordExp(span, Syntax.mapRecordRow doExp fields) @@ -796,7 +774,7 @@ fun forceTyIn (ctx : { nextTyVar : int ref, nextVId : 'a, matchContext : 'b, mes | doDec (ValDescDec { sourceSpan, expected = TypeScheme (tyvars, ty), actual = TypeScheme (tyvars', ty'), origin }) = ValDescDec { sourceSpan = sourceSpan, expected = TypeScheme (tyvars, doTy ty) (* should not be needed *), actual = TypeScheme (tyvars', doTy ty'), origin = origin } | doDec (ESImportDec { sourceSpan, pure, specs, moduleName }) = ESImportDec { sourceSpan = sourceSpan, pure = pure, specs = List.map (fn (name, vid, ty) => (name, vid, doTy ty)) specs, moduleName = moduleName } and doValBind(TupleBind(span, xs, exp)) = TupleBind(span, List.map (fn (vid, ty) => (vid, doTy ty)) xs, doExp exp) - | doValBind (PolyVarBind (span, vid, tysc as TypeScheme (tyvarsWithConstraints, ty), exp)) = PolyVarBind (span, vid, TypeScheme (tyvarsWithConstraints, doTy ty), doExp exp) + | doValBind (PolyVarBind (span, vid, TypeScheme (tyvarsWithConstraints, ty), exp)) = PolyVarBind (span, vid, TypeScheme (tyvarsWithConstraints, doTy ty), doExp exp) and doMatch(pat, exp) = (doPat pat, doExp exp) and doPat(pat as WildcardPat _) = pat | doPat(SConPat(span, scon, ty)) = SConPat(span, scon, doTy ty) @@ -870,7 +848,7 @@ fun freeTyVarsInPat (bound, pat) fun freeTyVarsInExp (bound, exp) = (case exp of SConExp (_, _, ty) => freeAnonymousTyVarsInTy ty - | VarExp (_, _, _, tyargs) => List.foldl (fn ((ty, cts), set) => freeAnonymousTyVarsInTy ty @ set) [] tyargs + | VarExp (_, _, _, tyargs) => List.foldl (fn ((ty, _), set) => freeAnonymousTyVarsInTy ty @ set) [] tyargs | RecordExp (_, xs) => List.foldl (fn ((_, exp), set) => freeTyVarsInExp (bound, exp) @ set) [] xs | RecordExtExp { sourceSpan = _, fields, baseExp, baseTy } => List.foldl (fn ((_, exp), set) => freeTyVarsInExp (bound, exp) @ set) (freeTyVarsInExp (bound, baseExp) @ freeAnonymousTyVarsInTy baseTy) fields | LetInExp (_, decls, exp) => freeTyVarsInDecs (bound, decls) @ freeTyVarsInExp (bound, exp) @@ -880,7 +858,7 @@ fun freeTyVarsInExp (bound, exp) | RaiseExp (_, ty, exp) => freeAnonymousTyVarsInTy ty @ freeTyVarsInExp (bound, exp) | IfThenElseExp (_, exp1, exp2, exp3) => freeTyVarsInExp (bound, exp1) @ freeTyVarsInExp (bound, exp2) @ freeTyVarsInExp (bound, exp3) | CaseExp { sourceSpan = _, subjectExp, subjectTy, matches, matchType = _, resultTy } => freeTyVarsInExp (bound, subjectExp) @ freeAnonymousTyVarsInTy subjectTy @ freeAnonymousTyVarsInTy resultTy @ freeTyVarsInMatches (bound, matches, []) - | FnExp (_, vid, ty, body) => freeAnonymousTyVarsInTy ty @ freeTyVarsInExp (bound, body) + | FnExp (_, _, ty, body) => freeAnonymousTyVarsInTy ty @ freeTyVarsInExp (bound, body) | ProjectionExp { recordTy = recordTy, fieldTy = fieldTy, ... } => freeAnonymousTyVarsInTy recordTy @ freeAnonymousTyVarsInTy fieldTy | ListExp (_, xs, ty) => Vector.foldl (fn (x, set) => freeTyVarsInExp (bound, x) @ set) (freeAnonymousTyVarsInTy ty) xs | VectorExp (_, xs, ty) => Vector.foldl (fn (x, set) => freeTyVarsInExp (bound, x) @ set) (freeAnonymousTyVarsInTy ty) xs @@ -889,7 +867,7 @@ fun freeTyVarsInExp (bound, exp) end | BogusExp (_, ty) => freeAnonymousTyVarsInTy ty ) -and freeTyVarsInMatches (bound, nil, acc) = acc +and freeTyVarsInMatches (_, nil, acc) = acc | freeTyVarsInMatches (bound, (pat, exp) :: rest, acc) = freeTyVarsInMatches (bound, rest, acc @ freeTyVarsInPat (bound, pat) @ freeTyVarsInExp (bound, exp)) and freeTyVarsInDecs (bound, decls) = List.foldl (fn (dec, set) => set @ freeTyVarsInDec (bound, dec)) [] decls and freeTyVarsInDec (bound, dec) @@ -900,29 +878,29 @@ and freeTyVarsInDec (bound, dec) | TypeDec (_, typbinds) => List.foldl (fn (typbind, acc) => acc @ freeAnonymousTyVarsInTypBind (bound, typbind)) [] typbinds | DatatypeDec (_, datbinds) => List.foldl (fn (datbind, acc) => acc @ freeTyVarsInDatBind (bound, datbind)) [] datbinds | ExceptionDec (_, exbinds) => List.foldl (fn (exbind, acc) => acc @ freeTyVarsInExBind (bound, exbind)) [] exbinds - | OverloadDec (_, class, tyname, map) => Syntax.OverloadKeyMap.foldl (fn (exp, acc) => acc @ freeTyVarsInExp (bound, exp)) [] map - | EqualityDec (_, typarams, tyname, exp) => freeTyVarsInExp (bound, exp) - | ValDescDec { sourceSpan, expected = TypeScheme (tyvars, ty), actual = TypeScheme (tyvars', ty'), origin } => freeAnonymousTyVarsInTy ty (* should be empty *) @ freeAnonymousTyVarsInTy ty' - | ESImportDec { sourceSpan, pure, specs, moduleName } => List.foldl (fn ((_, _, ty), acc) => acc @ freeAnonymousTyVarsInTy ty) [] specs + | OverloadDec (_, _, _, map) => Syntax.OverloadKeyMap.foldl (fn (exp, acc) => acc @ freeTyVarsInExp (bound, exp)) [] map + | EqualityDec (_, _, _, exp) => freeTyVarsInExp (bound, exp) + | ValDescDec { sourceSpan = _, expected = TypeScheme (_, ty), actual = TypeScheme (_, ty'), origin = _ } => freeAnonymousTyVarsInTy ty (* should be empty *) @ freeAnonymousTyVarsInTy ty' + | ESImportDec { sourceSpan = _, pure = _, specs, moduleName = _ } => List.foldl (fn ((_, _, ty), acc) => acc @ freeAnonymousTyVarsInTy ty) [] specs ) and freeTyVarsInValBind (bound, TupleBind(_, xs, exp)) = List.foldl (fn ((_, ty), acc) => acc @ freeAnonymousTyVarsInTy ty) (freeTyVarsInExp (bound, exp)) xs - | freeTyVarsInValBind (bound, PolyVarBind(_, vid, TypeScheme(tyvars, ty), exp)) = freeAnonymousTyVarsInTy ty @ freeTyVarsInExp (bound, exp) -and freeAnonymousTyVarsInTypBind (bound, TypBind (_, tyvars, tycon, ty)) = freeAnonymousTyVarsInTy ty -and freeTyVarsInDatBind (bound, DatBind (_, tyvars, tycon, conbinds, _)) = List.foldl (fn (conbind, acc) => acc @ freeTyVarsInConBind (bound, conbind)) [] conbinds -and freeTyVarsInConBind (bound, ConBind (_, vid, NONE, info)) = [] - | freeTyVarsInConBind (bound, ConBind (_, vid, SOME ty, info)) = freeAnonymousTyVarsInTy ty -and freeTyVarsInExBind (bound, ExBind (_, vid, NONE)) = [] - | freeTyVarsInExBind (bound, ExBind (_, vid, SOME ty)) = freeAnonymousTyVarsInTy ty - | freeTyVarsInExBind (bound, ExReplication (_, _, _, NONE)) = [] - | freeTyVarsInExBind (bound, ExReplication (_, _, _, SOME ty)) = freeAnonymousTyVarsInTy ty -and freeTyVarsInUnaryConstraint (bound, unaryConstraint) = [] + | freeTyVarsInValBind (bound, PolyVarBind (_, _, TypeScheme (_, ty), exp)) = freeAnonymousTyVarsInTy ty @ freeTyVarsInExp (bound, exp) +and freeAnonymousTyVarsInTypBind (_, TypBind (_, _, _, ty)) = freeAnonymousTyVarsInTy ty +and freeTyVarsInDatBind (bound, DatBind (_, _, _, conbinds, _)) = List.foldl (fn (conbind, acc) => acc @ freeTyVarsInConBind (bound, conbind)) [] conbinds +and freeTyVarsInConBind (_, ConBind (_, _, NONE, _)) = [] + | freeTyVarsInConBind (_, ConBind (_, _, SOME ty, _)) = freeAnonymousTyVarsInTy ty +and freeTyVarsInExBind (_ (* bound *), ExBind (_, _, NONE)) = [] + | freeTyVarsInExBind (_, ExBind (_, _, SOME ty)) = freeAnonymousTyVarsInTy ty + | freeTyVarsInExBind (_, ExReplication (_, _, _, NONE)) = [] + | freeTyVarsInExBind (_, ExReplication (_, _, _, SOME ty)) = freeAnonymousTyVarsInTy ty +(* and freeTyVarsInUnaryConstraint (_ (* bound *), _ (* unaryConstraint *)) = [] *) (*: val filterVarsInPat : (VId -> bool) -> Pat -> Pat *) fun filterVarsInPat pred = let fun doPat pat = case pat of WildcardPat _ => pat + | VarPat (span, vid, _) => if pred vid then pat else WildcardPat span | SConPat _ => pat - | VarPat(span, vid, ty) => if pred vid then pat else WildcardPat span | RecordPat { sourceSpan, fields, ellipsis, wholeRecordType } => RecordPat { sourceSpan = sourceSpan, fields = Syntax.mapRecordRow doPat fields, ellipsis = Option.map doPat ellipsis, wholeRecordType = wholeRecordType } | ConPat { payload = NONE, ... } => pat | ConPat { sourceSpan, longvid, payload = SOME (innerTy, innerPat), tyargs, valueConstructorInfo } => ConPat { sourceSpan = sourceSpan, longvid = longvid, payload = SOME (innerTy, doPat innerPat), tyargs = tyargs, valueConstructorInfo = valueConstructorInfo } diff --git a/src/typing.sml b/src/typing.sml index d47b120f..147d1f87 100644 --- a/src/typing.sml +++ b/src/typing.sml @@ -172,16 +172,16 @@ fun envWithFunMap funMap } fun envToSigEnv(env : Env) : SigEnv - = { valMap = Syntax.VIdMap.map (fn (tysc, ids, longvid) => (tysc, ids, ())) (#valMap env) + = { valMap = Syntax.VIdMap.map (fn (tysc, ids, _) => (tysc, ids, ())) (#valMap env) , tyConMap = #tyConMap env , tyNameMap = #tyNameMap env - , strMap = Syntax.StrIdMap.map (fn (s, longstrid) => (s, ())) (#strMap env) + , strMap = Syntax.StrIdMap.map (fn (s, _) => (s, ())) (#strMap env) , sigMap = #sigMap env , funMap = #funMap env , boundTyVars = #boundTyVars env } -fun freeTyVarsInEnv (bound, { valMap, tyConMap, tyNameMap, strMap, sigMap, funMap, boundTyVars } : Env) +fun freeTyVarsInEnv (_ (* bound *), { valMap = _, tyConMap = _, tyNameMap = _, strMap = _, sigMap = _, funMap = _, boundTyVars } : Env) = Syntax.TyVarMap.foldl (fn (tv, set) => TypedSyntax.TyVarSet.add (set, tv)) TypedSyntax.TyVarSet.empty boundTyVars type Context = { nextTyVar : int ref @@ -210,8 +210,8 @@ fun emitFatalError (ctx : Context, spans, message) = let val { matchContext, mes fun emitFatalTypeError (ctx : InferenceContext, spans, message) = emitFatalError (#context ctx, spans, message) (*: val lookupStr : Context * TypedSyntax.Signature * SourcePos.span * Syntax.StrId list -> TypedSyntax.Signature *) -fun lookupStr (ctx, s : TypedSyntax.Signature, span, nil) = s - | lookupStr(ctx, s as { strMap = strMap, ... }, span, (strid0 as Syntax.MkStrId name) :: strids) +fun lookupStr (_, s : TypedSyntax.Signature, _, nil) = s + | lookupStr (ctx, { strMap = strMap, ... }, span, (strid0 as Syntax.MkStrId name) :: strids) = (case Syntax.StrIdMap.find(strMap, strid0) of NONE => emitFatalError (ctx, [span], "unknown structure name '" ^ name ^ "'") | SOME (TypedSyntax.MkSignature innerEnv) => lookupStr (ctx, innerEnv, span, strids) @@ -242,20 +242,20 @@ datatype 'a LookupResult = Found of 'a | StructureNotFound of Syntax.StrId Syntax.Qualified (*: val lookupStr' : 'context * TypedSyntax.Signature * Syntax.StrId list * Syntax.StrId list -> TypedSyntax.Signature LookupResult *) -fun lookupStr' (ctx, s : TypedSyntax.Signature, _, nil) = Found s - | lookupStr' (ctx, s as { strMap, ... }, revStrIds, (strid0 as Syntax.MkStrId name) :: strids) +fun lookupStr' (_, s : TypedSyntax.Signature, _, nil) = Found s + | lookupStr' (ctx, { strMap, ... }, revStrIds, strid0 :: strids) = (case Syntax.StrIdMap.find (strMap, strid0) of NONE => StructureNotFound (Syntax.MkQualified (List.rev revStrIds, strid0)) | SOME (TypedSyntax.MkSignature innerEnv) => lookupStr' (ctx, innerEnv, strid0 :: revStrIds, strids) ) (*: val lookupLongVIdInEnv : 'context * Env * 'span * Syntax.LongVId -> (TypedSyntax.LongVId * TypedSyntax.TypeScheme * Syntax.ValueConstructorInfo Syntax.IdStatus) LookupResult *) -fun lookupLongVIdInEnv (ctx : 'context, env : Env, span, longvid as Syntax.MkQualified ([], vid)) +fun lookupLongVIdInEnv (_ : 'context, env : Env, _ (* span *), longvid as Syntax.MkQualified ([], vid)) = (case Syntax.VIdMap.find (#valMap env, vid) of SOME (tysc, ids, longvid) => Found (longvid, tysc, ids) | NONE => ValueNotFound longvid ) - | lookupLongVIdInEnv (ctx, env, span, longvid as Syntax.MkQualified (strid0 :: strids, vid)) + | lookupLongVIdInEnv (ctx, env, _, longvid as Syntax.MkQualified (strid0 :: strids, vid)) = (case Syntax.StrIdMap.find (#strMap env, strid0) of SOME (s, TypedSyntax.MkLongStrId (strid0, strids0)) => (case lookupStr' (ctx, s, [], strids) of @@ -273,41 +273,41 @@ fun lookupLongVIdInEnv (ctx : 'context, env : Env, span, longvid as Syntax.MkQua fun getConstructedType (ctx, span, TypedSyntax.TyVar _) = emitFatalError (ctx, [span], "getConstructedType: got a type variable") | getConstructedType (ctx, span, TypedSyntax.AnonymousTyVar _) = emitFatalError (ctx, [span], "getConstructedType: got a type variable") | getConstructedType (ctx, span, TypedSyntax.RecordType _) = emitFatalError (ctx, [span], "getConstructedType: got a record") - | getConstructedType (ctx, span, TypedSyntax.TyCon (_, tyargs, tycon)) = tycon + | getConstructedType (_, _, TypedSyntax.TyCon (_, _, tycon)) = tycon | getConstructedType (ctx, span, TypedSyntax.FnType (_, _, t)) = getConstructedType (ctx, span, t) | getConstructedType (ctx, span, TypedSyntax.RecordExtType _) = emitFatalError (ctx, [span], "getConstructedType: got a record") (* The Definition, 4.7 Non-expansive Expressions *) (*: val isNonexpansive : Env * TypedSyntax.Exp -> bool *) -fun isNonexpansive (env : Env, TypedSyntax.SConExp _) = true - | isNonexpansive (env, TypedSyntax.VarExp _) = true (* longvid *) +fun isNonexpansive (_ : Env, TypedSyntax.SConExp _) = true + | isNonexpansive (_, TypedSyntax.VarExp _) = true (* longvid *) | isNonexpansive (env, TypedSyntax.RecordExp (_, fields)) = List.all (fn (_, e) => isNonexpansive (env, e)) fields | isNonexpansive (env, TypedSyntax.TypedExp (_, e, _)) = isNonexpansive (env, e) | isNonexpansive (env, TypedSyntax.AppExp (_, conexp, e)) = isConexp (env, conexp) andalso isNonexpansive (env, e) - | isNonexpansive (env, TypedSyntax.FnExp _) = true - | isNonexpansive (env, TypedSyntax.ProjectionExp _) = true + | isNonexpansive (_, TypedSyntax.FnExp _) = true + | isNonexpansive (_, TypedSyntax.ProjectionExp _) = true | isNonexpansive (env, TypedSyntax.ListExp (_, xs, _)) = Vector.all (fn x => isNonexpansive (env, x)) xs | isNonexpansive (env, TypedSyntax.VectorExp (_, xs, _)) = Vector.all (fn x => isNonexpansive (env, x)) xs - | isNonexpansive (env, _) = false + | isNonexpansive (_, _) = false and isConexp (env : Env, TypedSyntax.TypedExp (_, e, _)) = isConexp (env, e) - | isConexp (env, TypedSyntax.VarExp (_, _, Syntax.ValueVariable, _)) = false - | isConexp (env, TypedSyntax.VarExp (_, TypedSyntax.MkShortVId (TypedSyntax.MkVId (name, _)), Syntax.ValueConstructor _, _)) = name <> "ref" - | isConexp (env, TypedSyntax.VarExp (_, TypedSyntax.MkLongVId (_, _, Syntax.MkVId name), Syntax.ValueConstructor _, _)) = name <> "ref" - | isConexp (env, TypedSyntax.VarExp (_, _, Syntax.ExceptionConstructor, _)) = true - | isConexp(env, _) = false + | isConexp (_, TypedSyntax.VarExp (_, _, Syntax.ValueVariable, _)) = false + | isConexp (_, TypedSyntax.VarExp (_, TypedSyntax.MkShortVId (TypedSyntax.MkVId (name, _)), Syntax.ValueConstructor _, _)) = name <> "ref" + | isConexp (_, TypedSyntax.VarExp (_, TypedSyntax.MkLongVId (_, _, Syntax.MkVId name), Syntax.ValueConstructor _, _)) = name <> "ref" + | isConexp (_, TypedSyntax.VarExp (_, _, Syntax.ExceptionConstructor, _)) = true + | isConexp (_, _) = false (*: val isExhaustive : 'context * Env * TypedSyntax.Pat -> bool *) -fun isExhaustive (ctx, env : Env, TypedSyntax.WildcardPat _) = true - | isExhaustive (ctx, env, TypedSyntax.SConPat _) = false - | isExhaustive (ctx, env, TypedSyntax.VarPat _) = true - | isExhaustive (ctx, env, TypedSyntax.RecordPat { sourceSpan, fields, ellipsis = NONE, wholeRecordType }) = List.all (fn (_, e) => isExhaustive (ctx, env, e)) fields - | isExhaustive (ctx, env, TypedSyntax.RecordPat { sourceSpan, fields, ellipsis = SOME ellipsisPat, wholeRecordType }) = List.all (fn (_, e) => isExhaustive (ctx, env, e)) fields andalso isExhaustive (ctx, env, ellipsisPat) - | isExhaustive (ctx, env, TypedSyntax.ConPat { sourceSpan, longvid, payload = NONE, tyargs, valueConstructorInfo = SOME info }) = Syntax.VIdSet.numItems (#allConstructors info) = 1 - | isExhaustive (ctx, env, TypedSyntax.ConPat { sourceSpan, longvid, payload = SOME (innerTy, innerPat), tyargs, valueConstructorInfo = SOME info }) = Syntax.VIdSet.numItems (#allConstructors info) = 1 andalso isExhaustive (ctx, env, innerPat) - | isExhaustive (ctx, env, TypedSyntax.ConPat { sourceSpan, longvid, payload, tyargs, valueConstructorInfo = NONE }) = false +fun isExhaustive (_, _ : Env, TypedSyntax.WildcardPat _) = true + | isExhaustive (_, _, TypedSyntax.SConPat _) = false + | isExhaustive (_, _, TypedSyntax.VarPat _) = true + | isExhaustive (ctx, env, TypedSyntax.RecordPat { sourceSpan = _, fields, ellipsis = NONE, wholeRecordType = _ }) = List.all (fn (_, e) => isExhaustive (ctx, env, e)) fields + | isExhaustive (ctx, env, TypedSyntax.RecordPat { sourceSpan = _, fields, ellipsis = SOME ellipsisPat, wholeRecordType = _ }) = List.all (fn (_, e) => isExhaustive (ctx, env, e)) fields andalso isExhaustive (ctx, env, ellipsisPat) + | isExhaustive (_, _, TypedSyntax.ConPat { sourceSpan = _, longvid = _, payload = NONE, tyargs = _, valueConstructorInfo = SOME info }) = Syntax.VIdSet.numItems (#allConstructors info) = 1 + | isExhaustive (ctx, env, TypedSyntax.ConPat { sourceSpan = _, longvid = _, payload = SOME (_, innerPat), tyargs = _, valueConstructorInfo = SOME info }) = Syntax.VIdSet.numItems (#allConstructors info) = 1 andalso isExhaustive (ctx, env, innerPat) + | isExhaustive (_, _, TypedSyntax.ConPat { sourceSpan = _, longvid = _, payload = _, tyargs = _, valueConstructorInfo = NONE }) = false | isExhaustive (ctx, env, TypedSyntax.TypedPat (_, innerPat, _)) = isExhaustive (ctx, env, innerPat) | isExhaustive (ctx, env, TypedSyntax.LayeredPat (_, _, _, innerPat)) = isExhaustive (ctx, env, innerPat) - | isExhaustive (ctx, env, TypedSyntax.VectorPat (_, pats, ellipsis, elemTy)) = ellipsis andalso Vector.length pats = 0 + | isExhaustive (_, _, TypedSyntax.VectorPat (_, pats, ellipsis, _)) = ellipsis andalso Vector.length pats = 0 val primTyName_int = TypedSyntax.MkTyName ("int", 0) val primTyName_word = TypedSyntax.MkTyName ("word", 1) @@ -355,7 +355,6 @@ val primTy_int64 = TypedSyntax.TyCon (SourcePos.nullSpan, [], primTyName_int64) val primTy_word32 = TypedSyntax.TyCon (SourcePos.nullSpan, [], primTyName_word32) val primTy_word64 = TypedSyntax.TyCon (SourcePos.nullSpan, [], primTyName_word64) val VId_Bind = TypedSyntax.MkVId ("Bind", ~1) -val LongVId_Bind = TypedSyntax.MkShortVId VId_Bind (* Index of user-defined identifiers start with 100 *) val VId_ref = TypedSyntax.MkVId ("ref", 0) @@ -485,7 +484,7 @@ fun occurCheckAndAdjustLevel tv ) | check (T.TyVar (_, _)) = false | check (T.RecordType (_, xs)) = Syntax.LabelMap.exists check xs - | check (T.TyCon (_, tyargs, tycon)) = List.exists check tyargs + | check (T.TyCon (_, tyargs, _)) = List.exists check tyargs | check (T.FnType (_, ty1, ty2)) = check ty1 orelse check ty2 | check (T.RecordExtType (_, xs, baseTy)) = Syntax.LabelMap.exists check xs orelse check baseTy in check @@ -506,20 +505,20 @@ fun instantiate (ctx : InferenceContext, span, T.TypeScheme (vars, ty)) (*: val solve : InferenceContext * Env * T.Constraint list -> unit *) (* The environment is used to determine if a data type admits equality *) -fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = () +fun solve (_ : InferenceContext, _ : Env, nil : T.Constraint list) : unit = () | solve (ctx, env, ct :: ctrs) = (case ct of - T.EqConstr (span1, T.AnonymousTyVar (span2, tv), ty) => unifyTyVarAndTy (ctx, env, span1, tv, ty, ctrs) - | T.EqConstr (span1, ty, T.AnonymousTyVar (span2, tv)) => unifyTyVarAndTy (ctx, env, span1, tv, ty, ctrs) - | T.EqConstr (span1, T.TyVar (span2, tv as T.MkTyVar (name, x)), T.TyVar (span3, tv' as T.MkTyVar (name', x'))) => + T.EqConstr (span1, T.AnonymousTyVar (_, tv), ty) => unifyTyVarAndTy (ctx, env, span1, tv, ty, ctrs) + | T.EqConstr (span1, ty, T.AnonymousTyVar (_, tv)) => unifyTyVarAndTy (ctx, env, span1, tv, ty, ctrs) + | T.EqConstr (span1, T.TyVar (span2, tv as T.MkTyVar (name, _)), T.TyVar (span3, tv' as T.MkTyVar (name', _))) => ( if T.eqUTyVar (tv, tv') then () (* do nothing *) else emitTypeError (ctx, [span1, span2, span3], "cannot unify named type variable: " ^ name ^ " and " ^ name') ; solve (ctx, env, ctrs) ) - | T.EqConstr (span1, T.TyVar (span2, T.MkTyVar (name, _)), ty) => (emitTypeError (ctx, [span1, span2], "cannot unify named type variable: " ^ name); solve (ctx, env, ctrs)) - | T.EqConstr (span1, ty, T.TyVar (span2, T.MkTyVar (name, _))) => (emitTypeError (ctx, [span1, span2], "cannot unify named type variable: " ^ name); solve (ctx, env, ctrs)) + | T.EqConstr (span1, T.TyVar (span2, T.MkTyVar (name, _)), _) => (emitTypeError (ctx, [span1, span2], "cannot unify named type variable: " ^ name); solve (ctx, env, ctrs)) + | T.EqConstr (span1, _, T.TyVar (span2, T.MkTyVar (name, _))) => (emitTypeError (ctx, [span1, span2], "cannot unify named type variable: " ^ name); solve (ctx, env, ctrs)) | T.EqConstr (span, T.FnType (_, s0, s1), T.FnType (_, t0, t1)) => solve (ctx, env, T.EqConstr (span, s0, t0) :: T.EqConstr (span, s1, t1) :: ctrs) | T.EqConstr (span1, T.RecordType (span2, fields), T.RecordType (span3, fields')) => let val incompatible = if Syntax.LabelMap.numItems fields <> Syntax.LabelMap.numItems fields' then @@ -539,7 +538,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = (emitTypeError (ctx, [span1, span2, span3], "unification failed: incompatible record types (different number of fields)"); true) else false - val extraFields = Syntax.LabelMap.filteri (fn (label, ty) => not (Syntax.LabelMap.inDomain (fields', label))) fields + val extraFields = Syntax.LabelMap.filteri (fn (label, _) => not (Syntax.LabelMap.inDomain (fields', label))) fields in solve (ctx, env, Syntax.LabelMap.foldli (fn (label, ty, acc) => case Syntax.LabelMap.find (fields, label) of NONE => ( if incompatible then () else emitTypeError (ctx, [span1, span2, span3], "unification failed: incompatible record types") @@ -552,7 +551,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = (emitTypeError (ctx, [span1, span2, span3], "unification failed: incompatible record types (different number of fields)"); true) else false - val extraFields = Syntax.LabelMap.filteri (fn (label, ty) => not (Syntax.LabelMap.inDomain (fields', label))) fields + val extraFields = Syntax.LabelMap.filteri (fn (label, _) => not (Syntax.LabelMap.inDomain (fields', label))) fields in solve (ctx, env, Syntax.LabelMap.foldli (fn (label, ty, acc) => case Syntax.LabelMap.find (fields, label) of NONE => ( if incompatible then () else emitTypeError (ctx, [span1, span2, span3], "unification failed: incompatible record types") @@ -562,8 +561,8 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = end | T.EqConstr (span1, T.RecordExtType (span2, fields, baseTy), T.RecordExtType (span3, fields', baseTy')) => let val commonFields = Syntax.LabelMap.listItems (Syntax.LabelMap.intersectWith (fn (ty, ty') => T.EqConstr (span1, ty, ty')) (fields, fields')) - val uniqueFields = Syntax.LabelMap.filteri (fn (label, ty) => not (Syntax.LabelMap.inDomain (fields', label))) fields - val uniqueFields' = Syntax.LabelMap.filteri (fn (label, ty) => not (Syntax.LabelMap.inDomain (fields, label))) fields' + val uniqueFields = Syntax.LabelMap.filteri (fn (label, _) => not (Syntax.LabelMap.inDomain (fields', label))) fields + val uniqueFields' = Syntax.LabelMap.filteri (fn (label, _) => not (Syntax.LabelMap.inDomain (fields, label))) fields' val ctrs = commonFields @ ctrs in case (Syntax.LabelMap.isEmpty uniqueFields, Syntax.LabelMap.isEmpty uniqueFields') of (true, true) => solve (ctx, env, T.EqConstr (span1, baseTy, baseTy') :: ctrs) @@ -599,7 +598,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = | T.TyCon (span2, _, _) => (emitTypeError (ctx, [span1, span2], "record field for a non-record type"); solve (ctx, env, ctrs)) | T.FnType (span2, _, _) => (emitTypeError (ctx, [span1, span2], "record field for a function type"); solve (ctx, env, ctrs)) | T.TyVar (span2, _) => (emitTypeError (ctx, [span1, span2], "record field for an named type variable"); solve (ctx, env, ctrs)) - | T.AnonymousTyVar (span2, tv) => + | T.AnonymousTyVar (_, tv) => (case !tv of T.Link replacement => solve (ctx, env, T.UnaryConstraint (span1, replacement, T.NoField label) :: ctrs) | T.Unbound (cts, level) => ( tv := T.Unbound ((span1, T.NoField label) :: cts, level) @@ -609,12 +608,12 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = ) | T.UnaryConstraint (span1, recordTy, T.IsRecord) => (case recordTy of - T.RecordType (span2, fields) => solve (ctx, env, ctrs) - | T.RecordExtType (span2, fields, baseTy) => solve (ctx, env, T.UnaryConstraint (span1, baseTy, T.IsRecord) :: ctrs) + T.RecordType (_, _) => solve (ctx, env, ctrs) + | T.RecordExtType (_, _, baseTy) => solve (ctx, env, T.UnaryConstraint (span1, baseTy, T.IsRecord) :: ctrs) | T.TyCon (span2, _, _) => (emitTypeError (ctx, [span1, span2], "record field for a non-record type"); solve (ctx, env, ctrs)) | T.FnType (span2, _, _) => (emitTypeError (ctx, [span1, span2], "record field for a function type"); solve (ctx, env, ctrs)) | T.TyVar (span2, _) => (emitTypeError (ctx, [span1, span2], "record field for an named type variable"); solve (ctx, env, ctrs)) - | T.AnonymousTyVar (span2, tv) => + | T.AnonymousTyVar (_, tv) => (case !tv of T.Link replacement => solve (ctx, env, T.UnaryConstraint (span1, replacement, T.IsRecord) :: ctrs) | T.Unbound (cts, level) => ( tv := T.Unbound ((span1, T.IsRecord) :: cts, level) @@ -622,7 +621,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = ) ) ) - | T.UnaryConstraint (span1, T.RecordType (span2, fields), T.IsEqType) => solve (ctx, env, Syntax.LabelMap.foldr (fn (ty, acc) => T.UnaryConstraint (span1, ty, T.IsEqType) :: acc) ctrs fields) + | T.UnaryConstraint (span1, T.RecordType (_, fields), T.IsEqType) => solve (ctx, env, Syntax.LabelMap.foldr (fn (ty, acc) => T.UnaryConstraint (span1, ty, T.IsEqType) :: acc) ctrs fields) | T.UnaryConstraint (span1, T.RecordType (span2, _), T.IsIntegral) => (emitTypeError (ctx, [span1, span2], "cannot apply arithmetic operator on record type"); solve (ctx, env, ctrs)) | T.UnaryConstraint (span1, T.RecordType (span2, _), T.IsSignedReal) => (emitTypeError (ctx, [span1, span2], "cannot apply arithmetic operator on record type"); solve (ctx, env, ctrs)) | T.UnaryConstraint (span1, T.RecordType (span2, _), T.IsRing) => (emitTypeError (ctx, [span1, span2], "cannot apply arithmetic operator on record type"); solve (ctx, env, ctrs)) @@ -632,7 +631,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = | T.UnaryConstraint (span1, T.RecordType (span2, _), T.IsReal) => (emitTypeError (ctx, [span1, span2], "cannot unify a record with a real"); solve (ctx, env, ctrs)) | T.UnaryConstraint (span1, T.RecordType (span2, _), T.IsChar) => (emitTypeError (ctx, [span1, span2], "cannot unify a record with a char"); solve (ctx, env, ctrs)) | T.UnaryConstraint (span1, T.RecordType (span2, _), T.IsString) => (emitTypeError (ctx, [span1, span2], "cannot unify a record with a string"); solve (ctx, env, ctrs)) - | T.UnaryConstraint (span1, T.RecordExtType (span2, fields, baseTy), T.IsEqType) => solve (ctx, env, T.UnaryConstraint (span1, baseTy, T.IsEqType) :: Syntax.LabelMap.foldr (fn (ty, acc) => T.UnaryConstraint (span1, ty, T.IsEqType) :: acc) ctrs fields) + | T.UnaryConstraint (span1, T.RecordExtType (_, fields, baseTy), T.IsEqType) => solve (ctx, env, T.UnaryConstraint (span1, baseTy, T.IsEqType) :: Syntax.LabelMap.foldr (fn (ty, acc) => T.UnaryConstraint (span1, ty, T.IsEqType) :: acc) ctrs fields) | T.UnaryConstraint (span1, T.RecordExtType (span2, _, _), T.IsIntegral) => (emitTypeError (ctx, [span1, span2], "cannot apply arithmetic operator on record type"); solve (ctx, env, ctrs)) | T.UnaryConstraint (span1, T.RecordExtType (span2, _, _), T.IsSignedReal) => (emitTypeError (ctx, [span1, span2], "cannot apply arithmetic operator on record type"); solve (ctx, env, ctrs)) | T.UnaryConstraint (span1, T.RecordExtType (span2, _, _), T.IsRing) => (emitTypeError (ctx, [span1, span2], "cannot apply arithmetic operator on record type"); solve (ctx, env, ctrs)) @@ -663,7 +662,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = ; solve (ctx, env, ctrs) ) end - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsIntegral) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsIntegral) => let val { overloadClass, ... } = lookupTyNameInEnv (#context ctx, env, span2, tyname) val isIntegral = case overloadClass of SOME Syntax.CLASS_INT => true @@ -675,7 +674,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = emitTypeError (ctx, [span1, span2], "arithmetic operator on unsupported type") ; solve (ctx, env, ctrs) end - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsSignedReal) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsSignedReal) => let val { overloadClass, ... } = lookupTyNameInEnv (#context ctx, env, span2, tyname) val isSignedReal = case overloadClass of SOME Syntax.CLASS_INT => true @@ -687,7 +686,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = emitTypeError (ctx, [span1, span2], "arithmetic operator on unsupported type") ; solve (ctx, env, ctrs) end - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsRing) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsRing) => let val { overloadClass, ... } = lookupTyNameInEnv (#context ctx, env, span2, tyname) val isRing = case overloadClass of SOME Syntax.CLASS_INT => true @@ -700,7 +699,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = emitTypeError (ctx, [span1, span2], "arithmetic operator on unsupported type") ; solve (ctx, env, ctrs) end - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsOrdered) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsOrdered) => let val { overloadClass, ... } = lookupTyNameInEnv (#context ctx, env, span2, tyname) val isOrdered = case overloadClass of SOME Syntax.CLASS_INT => true @@ -715,7 +714,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = emitTypeError (ctx, [span1, span2], "comparison operator on unsupported type") ; solve (ctx, env, ctrs) end - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsInt) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsInt) => ( if TypedSyntax.eqTyName (tyname, primTyName_int) then () (* do nothing *) else if TypedSyntax.eqTyName (tyname, primTyName_intInf) then @@ -735,7 +734,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = end ; solve (ctx, env, ctrs) ) - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsWord) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsWord) => ( if TypedSyntax.eqTyName (tyname, primTyName_word) then () (* do nothing *) else if TypedSyntax.eqTyName (tyname, primTyName_word32) then @@ -751,7 +750,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = end ; solve (ctx, env, ctrs) ) - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsReal) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsReal) => ( if TypedSyntax.eqTyName (tyname, primTyName_real) then () (* do nothing *) else @@ -763,7 +762,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = end ; solve (ctx, env, ctrs) ) - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsChar) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsChar) => ( if TypedSyntax.eqTyName (tyname, primTyName_char) then () (* do nothing *) else @@ -775,7 +774,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = end ; solve (ctx, env, ctrs) ) - | T.UnaryConstraint (span1, T.TyCon (span2, tyargs, tyname), T.IsString) => + | T.UnaryConstraint (span1, T.TyCon (span2, _, tyname), T.IsString) => ( if TypedSyntax.eqTyName (tyname, primTyName_string) then () (* do nothing *) else @@ -794,11 +793,11 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = emitTypeError (ctx, [span1, span2], "the type variable " ^ name ^ " does not admit equality") ; solve (ctx, env, ctrs) ) - | T.UnaryConstraint (span1, T.TyVar (span2, tv as T.MkTyVar (name, _)), _) => + | T.UnaryConstraint (span1, T.TyVar (span2, T.MkTyVar (name, _)), _) => ( emitTypeError (ctx, [span1, span2], "the use of " ^ name ^ " is non-free") ; solve (ctx, env, ctrs) ) - | T.UnaryConstraint (span1, T.AnonymousTyVar (span2, tv), pred) => + | T.UnaryConstraint (span1, T.AnonymousTyVar (_, tv), pred) => (case !tv of T.Link replacement => solve (ctx, env, T.UnaryConstraint (span1, replacement, pred) :: ctrs) | T.Unbound (cts, level) => ( tv := T.Unbound ((span1, pred) :: cts, level) @@ -809,7 +808,7 @@ fun solve (ctx : InferenceContext, env : Env, nil : T.Constraint list) : unit = and unifyTyVarAndTy (ctx : InferenceContext, env : Env, span : SourcePos.span, tv : T.AnonymousTyVar, ty : T.Ty, ctrs : T.Constraint list) : unit = (case !tv of T.Link replacement => solve (ctx, env, T.EqConstr (span, replacement, ty) :: ctrs) - | T.Unbound (cts, level) => + | T.Unbound (cts, _) => let val ty = T.forceTy ty in if (case ty of T.AnonymousTyVar (_, tv') => tv = tv' | _ => false) then (* ty = AnonymousTyVar tv *) solve (ctx, env, ctrs) (* do nothing *) @@ -867,11 +866,11 @@ fun forceTy (T.AnonymousTyVar (_, ref (T.Link ty))) = forceTy ty val synthTypeOfPat : InferenceContext * Env * S.Pat -> T.Ty * (T.VId * T.Ty) S.VIdMap.map * T.Pat and checkTypeOfPat : InferenceContext * Env * S.Pat * T.Ty -> (T.VId * T.Ty) S.VIdMap.map * T.Pat *) -fun synthTypeOfPat (ctx : InferenceContext, env : Env, S.WildcardPat span) : T.Ty * (T.VId * T.Ty) S.VIdMap.map * T.Pat +fun synthTypeOfPat (ctx : InferenceContext, _ : Env, S.WildcardPat span) : T.Ty * (T.VId * T.Ty) S.VIdMap.map * T.Pat = let val ty = T.AnonymousTyVar (span, freshTyVar (ctx, span, [])) in (ty, S.VIdMap.empty, T.WildcardPat span) end - | synthTypeOfPat (ctx, env, S.SConPat (span, scon)) + | synthTypeOfPat (ctx, _, S.SConPat (span, scon)) = (case scon of Syntax.IntegerConstant _ => let val tv = freshTyVar (ctx, span, [T.IsInt, T.IsEqType]) val ty = T.AnonymousTyVar (span, tv) @@ -891,18 +890,18 @@ fun synthTypeOfPat (ctx : InferenceContext, env : Env, S.WildcardPat span) : T.T in (ty, S.VIdMap.empty, T.SConPat (span, scon, ty)) end ) - | synthTypeOfPat (ctx, env, S.VarPat (span, vid as S.MkVId "_Prim.ref")) + | synthTypeOfPat (ctx, _, S.VarPat (span, vid as S.MkVId "_Prim.ref")) = let val payloadTy = TypedSyntax.AnonymousTyVar (span, freshTyVar (ctx, span, [])) val ty = T.FnType (span, payloadTy, T.TyCon (span, [payloadTy], primTyName_ref)) in (ty, S.VIdMap.singleton (vid, (VId_ref, ty)), T.VarPat (span, VId_ref, ty)) end - | synthTypeOfPat (ctx, env, S.VarPat (span, vid as S.MkVId "_Prim.::")) + | synthTypeOfPat (ctx, _, S.VarPat (span, vid as S.MkVId "_Prim.::")) = let val elemTy = TypedSyntax.AnonymousTyVar (span, freshTyVar (ctx, span, [])) val listTy = T.TyCon (span, [elemTy], primTyName_list) val ty = T.FnType (span, T.PairType (span, elemTy, listTy), listTy) in (ty, S.VIdMap.singleton (vid, (VId_DCOLON, ty)), T.VarPat (span, VId_DCOLON, ty)) end - | synthTypeOfPat (ctx, env, S.VarPat (span, vid as S.MkVId "_Prim.unit.equal")) + | synthTypeOfPat (_, _, S.VarPat (span, vid as S.MkVId "_Prim.unit.equal")) = let val ty = T.FnType (span, T.PairType (span, primTy_unit, primTy_unit), primTy_bool) in (ty, S.VIdMap.singleton (vid, (VId_unit_equal, ty)), T.VarPat (span, VId_unit_equal, ty)) end @@ -945,7 +944,7 @@ fun synthTypeOfPat (ctx : InferenceContext, env : Env, S.WildcardPat span) : T.T NONE => (ty, Syntax.VIdMap.empty, T.ConPat { sourceSpan = span, longvid = longvid, payload = NONE, tyargs = List.map #1 tyargs, valueConstructorInfo = valueConstructorInfo }) | SOME innerPat => (case ty of - T.FnType (span', argTy, resultTy) => + T.FnType (_, argTy, resultTy) => let val (innerVars, innerPat') = checkTypeOfPat (ctx, env, innerPat, argTy) in (resultTy, innerVars, T.ConPat { sourceSpan = span, longvid = longvid, payload = SOME (argTy, innerPat'), tyargs = List.map #1 tyargs, valueConstructorInfo = valueConstructorInfo }) end @@ -998,7 +997,7 @@ fun synthTypeOfPat (ctx : InferenceContext, env : Env, S.WildcardPat span) : T.T in (T.TyCon (span, [elemTy], primTyName_vector), vars, T.VectorPat (span, pats, ellipsis, elemTy)) end ) -and checkTypeOfPat (ctx : InferenceContext, env : Env, S.WildcardPat span, expectedTy) : (T.VId * T.Ty) S.VIdMap.map * T.Pat +and checkTypeOfPat (_ : InferenceContext, _ : Env, S.WildcardPat span, _) : (T.VId * T.Ty) S.VIdMap.map * T.Pat = (S.VIdMap.empty, T.WildcardPat span) | checkTypeOfPat (ctx, env, S.SConPat (span, scon), expectedTy) = (case scon of @@ -1110,16 +1109,16 @@ and checkTypeOfPat (ctx : InferenceContext, env : Env, S.WildcardPat span, expec ; (map, pat) end -fun doWithtype(ctx, env, typbinds : S.TypBind list) : S.ConBind -> S.ConBind - = let val map = List.foldl (fn (S.TypBind (span, tyvars, tycon, ty), map) => S.TyConMap.insert (map, tycon, (tyvars, ty))) S.TyConMap.empty typbinds - fun goTyAlias env (ty as S.TyVar (span, tv)) = (case S.TyVarMap.find (env, tv) of - SOME ty => ty - | NONE => ty - ) +fun doWithtype (ctx, _ (* Env *), typbinds : S.TypBind list) : S.ConBind -> S.ConBind + = let val map = List.foldl (fn (S.TypBind (_, tyvars, tycon, ty), map) => S.TyConMap.insert (map, tycon, (tyvars, ty))) S.TyConMap.empty typbinds + fun goTyAlias env (ty as S.TyVar (_, tv)) = (case S.TyVarMap.find (env, tv) of + SOME ty => ty + | NONE => ty + ) | goTyAlias env (S.RecordType (span, fields, optBaseTy)) = S.RecordType (span, List.map (fn (label, ty) => (label, goTyAlias env ty)) fields, Option.map (goTyAlias env) optBaseTy) | goTyAlias env (S.TyCon (span, tyargs, longtycon)) = S.TyCon (span, List.map (goTyAlias env) tyargs, longtycon) | goTyAlias env (S.FnType (span, s, t)) = S.FnType (span, goTyAlias env s, goTyAlias env t) - fun goTy (ty as S.TyVar (span, tv)) = ty + fun goTy (ty as S.TyVar (_, _)) = ty | goTy (S.RecordType (span, fields, optBaseTy)) = S.RecordType (span, List.map (fn (label, ty) => (label, goTy ty)) fields, Option.map goTy optBaseTy) | goTy (S.TyCon (span, tyargs, Syntax.MkQualified ([], tycon))) = let val tyargs = List.map goTy tyargs in case S.TyConMap.find (map, tycon) of @@ -1131,7 +1130,7 @@ fun doWithtype(ctx, env, typbinds : S.TypBind list) : S.ConBind -> S.ConBind end | goTy (S.TyCon (span, tyargs, longtycon)) = S.TyCon (span, List.map goTy tyargs, longtycon) | goTy (S.FnType (span, s, t)) = S.FnType (span, goTy s, goTy t) - fun goConBind (conbind as S.ConBind (span, vid, NONE)) = conbind + fun goConBind (conbind as S.ConBind (_, _, NONE)) = conbind | goConBind (S.ConBind (span, vid, SOME payloadTy)) = S.ConBind (span, vid, SOME (goTy payloadTy)) in goConBind end @@ -1141,24 +1140,23 @@ fun determineDatatypeEquality(ctx, env : ('val,'str) Env', datbinds : (S.TyVar l val graph : (S.TyConSet.set ref) S.TyConMap.map = Syntax.TyConMap.map (fn _ => ref S.TyConSet.empty) datbinds val nonEqualitySet = ref S.TyConSet.empty fun doDatBind (tycon, (tyvars, payloads)) - = let val r = S.TyConMap.lookup (graph, tycon) - fun doTy (S.TyVar (span, tv)) = if List.exists (fn tv' => tv = tv') tyvars then - SOME [] - else - (case tv of - S.MkTyVar name => if String.isPrefix "''" name then - SOME [] - else - NONE - ) - | doTy (S.RecordType (span, fields, NONE)) = doTypes (List.map #2 fields) - | doTy (S.RecordType (span, fields, SOME baseTy)) = (case doTypes (List.map #2 fields) of - SOME xs => (case doTy baseTy of - SOME ys => SOME (xs @ ys) - | none as NONE => none - ) - | none as NONE => none - ) + = let fun doTy (S.TyVar (_, tv)) = if List.exists (fn tv' => tv = tv') tyvars then + SOME [] + else + (case tv of + S.MkTyVar name => if String.isPrefix "''" name then + SOME [] + else + NONE + ) + | doTy (S.RecordType (_, fields, NONE)) = doTypes (List.map #2 fields) + | doTy (S.RecordType (_, fields, SOME baseTy)) = (case doTypes (List.map #2 fields) of + SOME xs => (case doTy baseTy of + SOME ys => SOME (xs @ ys) + | none as NONE => none + ) + | none as NONE => none + ) | doTy (S.TyCon (span, tyargs, longtycon)) = let val l = case longtycon of Syntax.MkQualified([], tycon) => @@ -1171,16 +1169,16 @@ fun determineDatatypeEquality(ctx, env : ('val,'str) Env', datbinds : (S.TyVar l result as SOME _ => result | NONE => let val { typeFunction = T.TypeFunction (tyvars, ty), ... } = lookupTyConInEnv (ctx, env, span, longtycon) val tyVarMap = ListPair.foldlEq (fn (tv, ty, m) => T.TyVarMap.insert (m, tv, ty)) T.TyVarMap.empty (tyvars, tyargs) - fun doUTy (T.TyVar (span, tv)) = (case T.TyVarMap.find (tyVarMap, tv) of - SOME ty => doTy ty - | NONE => if T.tyVarAdmitsEquality tv then - SOME [] - else - NONE - ) + fun doUTy (T.TyVar (_, tv)) = (case T.TyVarMap.find (tyVarMap, tv) of + SOME ty => doTy ty + | NONE => if T.tyVarAdmitsEquality tv then + SOME [] + else + NONE + ) | doUTy (T.AnonymousTyVar _) = NONE (* should not occur *) - | doUTy (T.RecordType (span, fields)) = doUTypes (Syntax.LabelMap.foldl (op ::) [] fields) - | doUTy (T.RecordExtType (span, fields, baseTy)) = doUTypes (Syntax.LabelMap.foldl (op ::) [baseTy] fields) (* should not occur *) + | doUTy (T.RecordType (_, fields)) = doUTypes (Syntax.LabelMap.foldl (op ::) [] fields) + | doUTy (T.RecordExtType (_, fields, baseTy)) = doUTypes (Syntax.LabelMap.foldl (op ::) [baseTy] fields) (* should not occur *) | doUTy (T.TyCon (span, tyargs, tyname)) = if isRefOrArray tyname then SOME [] else @@ -1241,19 +1239,19 @@ and synthTypeOfMatch : InferenceContext * Env * SourcePos.span * (S.Pat * S.Exp) and checkAndSynthTypeOfMatch : InferenceContext * Env * SourcePos.span * (S.Pat * S.Exp) list * (* pattern type *) T.Ty -> (* expression type *) T.Ty * (T.Pat * T.Exp) list and checkTypeOfMatch : InferenceContext * Env * (S.Pat * S.Exp) list * (* pattern type *) T.Ty * (* expression type *) T.Ty -> (T.Pat * T.Exp) list *) -fun synthTypeOfExp (ctx : InferenceContext, env : Env, S.SConExp (span, scon)) : T.Ty * T.Exp +fun synthTypeOfExp (ctx : InferenceContext, _ : Env, S.SConExp (span, scon)) : T.Ty * T.Exp = let val ty = case scon of - Syntax.IntegerConstant x => let val tv = freshTyVar (ctx, span, [T.IsInt]) + Syntax.IntegerConstant _ => let val tv = freshTyVar (ctx, span, [T.IsInt]) in T.AnonymousTyVar (span, tv) end - | Syntax.WordConstant x => let val tv = freshTyVar (ctx, span, [T.IsWord]) + | Syntax.WordConstant _ => let val tv = freshTyVar (ctx, span, [T.IsWord]) in T.AnonymousTyVar (span, tv) end - | Syntax.RealConstant x => primTy_real (* TODO: overloaded literals *) - | Syntax.CharacterConstant x => let val tv = freshTyVar (ctx, span, [T.IsChar]) + | Syntax.RealConstant _ => primTy_real (* TODO: overloaded literals *) + | Syntax.CharacterConstant _ => let val tv = freshTyVar (ctx, span, [T.IsChar]) in T.AnonymousTyVar (span, tv) end - | Syntax.StringConstant x => let val tv = freshTyVar (ctx, span, [T.IsString]) + | Syntax.StringConstant _ => let val tv = freshTyVar (ctx, span, [T.IsString]) in T.AnonymousTyVar (span, tv) end in (ty, T.SConExp (span, scon, ty)) @@ -1343,13 +1341,13 @@ fun synthTypeOfExp (ctx : InferenceContext, env : Env, S.SConExp (span, scon)) : | synthTypeOfExp (ctx, env, S.FnExp (span, matches)) = let val (argTy, retTy, matches) = synthTypeOfMatch (ctx, env, span, matches) val fnExp = case matches of - [(T.VarPat (span2, vid, _), body)] => T.FnExp (span, vid, argTy, body) + [(T.VarPat (_, vid, _), body)] => T.FnExp (span, vid, argTy, body) | _ => let val vid = newVId (#context ctx, Syntax.MkVId "a") in T.FnExp (span, vid, argTy, T.CaseExp { sourceSpan = span, subjectExp = T.VarExp (span, T.MkShortVId vid, Syntax.ValueVariable, []), subjectTy = argTy, matches = matches, matchType = T.CASE, resultTy = retTy }) end in (T.FnType (span, argTy, retTy), fnExp) end - | synthTypeOfExp (ctx, env, S.ProjectionExp (span, label)) + | synthTypeOfExp (ctx, _, S.ProjectionExp (span, label)) = let val fieldTy = TypedSyntax.AnonymousTyVar (span, freshTyVar (ctx, span, [])) val baseTy = T.AnonymousTyVar (span, freshTyVar (ctx, span, [T.NoField label, T.IsRecord])) val recordTy = T.RecordExtType (span, Syntax.LabelMap.insert (Syntax.LabelMap.empty, label, fieldTy), baseTy) @@ -1421,11 +1419,11 @@ fun synthTypeOfExp (ctx : InferenceContext, env : Env, S.SConExp (span, scon)) : end and checkTypeOfExp (ctx, env, S.SConExp (span, scon), expectedTy : T.Ty) : T.Exp = ( case scon of - Syntax.IntegerConstant x => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsInt)) - | Syntax.WordConstant x => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsWord)) - | Syntax.RealConstant x => solve (ctx, env, [T.EqConstr (span, primTy_real, expectedTy)]) (* TODO: overloaded literals *) - | Syntax.CharacterConstant x => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsChar)) - | Syntax.StringConstant x => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsString)) + Syntax.IntegerConstant _ => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsInt)) + | Syntax.WordConstant _ => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsWord)) + | Syntax.RealConstant _ => solve (ctx, env, [T.EqConstr (span, primTy_real, expectedTy)]) (* TODO: overloaded literals *) + | Syntax.CharacterConstant _ => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsChar)) + | Syntax.StringConstant _ => addConstraint (ctx, env, T.UnaryConstraint (span, expectedTy, T.IsString)) ; T.SConExp (span, scon, expectedTy) ) | checkTypeOfExp (ctx, env, exp as S.RecordExp (span, fields, NONE), expectedTy) @@ -1506,7 +1504,7 @@ and checkTypeOfExp (ctx, env, S.SConExp (span, scon), expectedTy : T.Ty) : T.Exp T.FnType (_, argTy, retTy) => let val matches = checkTypeOfMatch (ctx, env, matches, argTy, retTy) in case matches of - [(T.VarPat (span2, vid, _), body)] => T.FnExp (span, vid, argTy, body) + [(T.VarPat (_, vid, _), body)] => T.FnExp (span, vid, argTy, body) | _ => let val vid = newVId (#context ctx, Syntax.MkVId "a") in T.FnExp (span, vid, argTy, T.CaseExp { sourceSpan = span, subjectExp = T.VarExp (span, T.MkShortVId vid, Syntax.ValueVariable, []), subjectTy = argTy, matches = matches, matchType = T.CASE, resultTy = retTy }) end @@ -1692,7 +1690,7 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d val allPoly = List.all (fn (_, T.TypeScheme (tv, _)) => not (List.null tv)) valEnv'L (* all bindings are generalized? *) val espan = TypedSyntax.getSourceSpanOfExp exp fun polyPart [] = [] - | polyPart ((vid, T.TypeScheme ([], _)) :: rest) = polyPart rest + | polyPart ((_, T.TypeScheme ([], _)) :: rest) = polyPart rest | polyPart ((vid, tysc as T.TypeScheme (_, ty)) :: rest) = let val vid' = renewVId (#context ctx) vid val pat' = TypedSyntax.renameVarsInPat (TypedSyntax.VIdMap.insert (TypedSyntax.VIdMap.empty, vid, vid')) pat @@ -1785,7 +1783,7 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d end ) valbinds' val tyVars_env = freeTyVarsInEnv (T.TyVarSet.empty, env) - fun generalize ({ sourceSpan = span, pat, exp, expTy, valEnv }, (valbinds, valEnvRest, tyVarsAcc)) + fun generalize ({ sourceSpan = span, pat = _, exp, expTy, valEnv }, (valbinds, valEnvRest, tyVarsAcc)) = let fun doVal (vid, ty) = let val ty = T.forceTy ty val tyVars = T.freeTyVarsInTy (tyVars_env, ty) @@ -1833,7 +1831,7 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d in (valbinds, Syntax.VIdMap.unionWith #2 (valEnv', valEnvRest), T.TyVarSet.union (aTyVars, tyVarsAcc)) end val (valbinds, valEnv, allTyVars) = List.foldr generalize ([], Syntax.VIdMap.empty, T.TyVarSet.fromList (List.map #2 tyvarseq')) valbinds'' - fun fixRecursion (span, vid, tysc as T.TypeScheme (tyvars, ty), exp) + fun fixRecursion (span, vid, tysc as T.TypeScheme (tyvars, _), exp) = let val unboundTyVars = T.TyVarSet.foldl (fn (tv, acc) => if List.exists (fn (tv', _) => tv = tv') tyvars then acc @@ -1908,8 +1906,8 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d in List.map (fn S.DatBind (span, tyvars, tycon, optBar, conbinds) => S.DatBind (span, tyvars, tycon, optBar, List.map goConBind conbinds)) datbinds end val equalityMap : bool S.TyConMap.map = determineDatatypeEquality (#context ctx, env, List.foldl (fn (S.DatBind (_, tyvars, tycon, _, conbinds), m) => S.TyConMap.insert (m, tycon, (tyvars, List.mapPartial (fn S.ConBind (_, _, optTy) => optTy) conbinds))) S.TyConMap.empty datbinds) - val datbinds = List.map (fn datbind as S.DatBind (span, tyvars, tycon, _, conbinds) => (datbind, newTyName (#context ctx, tycon))) datbinds - val partialEnv = envWithTyConEnv (List.foldl (fn ((S.DatBind (span, tyvars, tycon, _, conbinds), tycon'), (m, m')) => + val datbinds = List.map (fn datbind as S.DatBind (_, _, tycon, _, _) => (datbind, newTyName (#context ctx, tycon))) datbinds + val partialEnv = envWithTyConEnv (List.foldl (fn ((S.DatBind (span, tyvars, tycon, _, _), tycon'), (m, m')) => let val tyvars = List.map (fn tv => genTyVar (#context ctx, tv)) tyvars val tystr = { typeFunction = T.TypeFunction (tyvars, T.TyCon (span, List.map (fn tv => T.TyVar (span, tv)) tyvars, tycon')) , valEnv = T.emptyValEnv @@ -1934,8 +1932,8 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d } ) val tyvars = List.map #2 tyvars - val allConstructors = List.foldl (fn (Syntax.ConBind (span, vid, _), set) => Syntax.VIdSet.add (set, vid)) Syntax.VIdSet.empty conbinds - val constructorsWithPayload = List.foldl (fn (Syntax.ConBind (span, vid, optTy), set) => if Option.isSome optTy then Syntax.VIdSet.add (set, vid) else set) Syntax.VIdSet.empty conbinds + val allConstructors = List.foldl (fn (Syntax.ConBind (_, vid, _), set) => Syntax.VIdSet.add (set, vid)) Syntax.VIdSet.empty conbinds + val constructorsWithPayload = List.foldl (fn (Syntax.ConBind (_, vid, optTy), set) => if Option.isSome optTy then Syntax.VIdSet.add (set, vid) else set) Syntax.VIdSet.empty conbinds val representation = case conbinds of [S.ConBind (_, _, SOME _)] => Syntax.REP_ALIAS | [S.ConBind (_, _, NONE)] => Syntax.REP_UNIT @@ -2014,7 +2012,7 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d ) | Syntax.MkQualified(strid0 :: strids, _) => case Syntax.StrIdMap.find(#strMap env, strid0) of - SOME (s, T.MkLongStrId (strid0, strids0)) => (fn vid => T.MkLongVId (strid0, strids0 @ strids, vid)) + SOME (_, T.MkLongStrId (strid0, strids0)) => (fn vid => T.MkLongVId (strid0, strids0 @ strids, vid)) | NONE => emitFatalTypeError (ctx, [span], "datatype replication: structure " ^ Syntax.print_StrId strid0 ^ " not found (internal error)") val env' = { valMap = Syntax.VIdMap.mapi (fn (vid, (tysc, ids)) => (tysc, ids, getLongVId vid)) (#valEnv tystr) , tyConMap = Syntax.TyConMap.singleton(tycon, tystr) @@ -2066,7 +2064,7 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d val (valMap, exbinds) = List.foldr doExBind (Syntax.VIdMap.empty, []) exbinds in (envWithValEnv valMap, [T.ExceptionDec (span, exbinds)]) end - | typeCheckDec(ctx, env, S.LocalDec(span, decs1, decs2)) + | typeCheckDec (ctx, env, S.LocalDec (_, decs1, decs2)) = let val (env', decs1) = typeCheckDecs(ctx, env, decs1) val (env'', decs2) = typeCheckDecs(ctx, mergeEnv(env, env'), decs2) val env'' = { valMap = #valMap env'' @@ -2250,7 +2248,7 @@ and typeCheckDec (ctx : InferenceContext, env : Env, S.ValDec (span, tyvarseq, d } in (env', [T.ESImportDec { sourceSpan = sourceSpan, pure = pure, specs = List.map (fn (name, _, vid, ty) => (name, vid, ty)) specs', moduleName = moduleName }]) end -and typeCheckDecs (ctx, env, []) : Env * T.Dec list = (emptyEnv, []) +and typeCheckDecs (_, _, []) : Env * T.Dec list = (emptyEnv, []) | typeCheckDecs(ctx, env, dec :: decs) = let val (env', dec) = typeCheckDec(ctx, env, dec) val (env'', decs) = typeCheckDecs(ctx, mergeEnv(env, env'), decs) in (mergeEnv(env', env''), dec @ decs) @@ -2272,7 +2270,7 @@ and synthTypeOfMatch (ctx, env, span, (pat0, exp0) :: rest) : T.Ty * T.Ty * (T.P val rest' = List.map doBranch' rest in (patTy, expTy, (pat0', exp0') :: rest') end - | synthTypeOfMatch (ctx, env, span, nil) = emitFatalTypeError (ctx, [span], "invalid syntax tree: match is empty") + | synthTypeOfMatch (ctx, _, span, nil) = emitFatalTypeError (ctx, [span], "invalid syntax tree: match is empty") and checkAndSynthTypeOfMatch (ctx, env, span, (pat0, exp0) :: rest, expectedPatTy) : T.Ty * (T.Pat * T.Exp) list = let fun doBranch (pat, exp) = let val (vars, pat') = checkTypeOfPat (ctx, env, pat, expectedPatTy) @@ -2289,7 +2287,7 @@ and checkAndSynthTypeOfMatch (ctx, env, span, (pat0, exp0) :: rest, expectedPatT val rest' = List.map doBranch' rest in (expTy, (pat0', exp0') :: rest') end - | checkAndSynthTypeOfMatch (ctx, env, span, nil, _) = emitFatalTypeError (ctx, [span], "invalid syntax tree: match is empty") + | checkAndSynthTypeOfMatch (ctx, _, span, nil, _) = emitFatalTypeError (ctx, [span], "invalid syntax tree: match is empty") and checkTypeOfMatch (ctx, env, patsAndExps : (S.Pat * S.Exp) list, expectedPatTy : T.Ty, expectedExpTy : T.Ty) : (T.Pat * T.Exp) list = let fun doBranch (pat, exp) = let val (vars, pat') = checkTypeOfPat (ctx, env, pat, expectedPatTy) @@ -2400,7 +2398,7 @@ fun applyDefaultTypes (ctx, decs : T.Dec list) : unit = ) xs ; primTy_string ) - fun doIntOrReal (span1, []) = primTy_int + fun doIntOrReal (_, []) = primTy_int | doIntOrReal (span1, (span2, c) :: xs) = case c of TypedSyntax.NoField _ => (emitError (ctx, [span1, span2], "unresolved flex record"); doIntOrReal (span1, xs)) @@ -2415,7 +2413,7 @@ fun applyDefaultTypes (ctx, decs : T.Dec list) : unit = | TypedSyntax.IsReal => doReal (span1, xs) (* cannot occur *) | TypedSyntax.IsChar => doIntOrReal (span1, xs) (* cannot occur *) | TypedSyntax.IsString => doIntOrReal (span1, xs) (* cannot occur *) - fun defaultTyForConstraints (eq, spans, []) = primTy_unit + fun defaultTyForConstraints (_, _, []) = primTy_unit | defaultTyForConstraints (eq, spans, (span1, c) :: xs) = case c of TypedSyntax.NoField _ => (emitError (ctx, [span1], "unresolved flex record"); defaultTyForConstraints (eq, spans, xs)) @@ -2445,13 +2443,13 @@ fun applyDefaultTypes (ctx, decs : T.Dec list) : unit = end local - fun checkValDesc (ctx, env, span, expected as T.TypeScheme (tyvarsE, tyE), actual as T.TypeScheme (tyvarsA, tyA), origin) + fun checkValDesc (ctx, _, span, expected as T.TypeScheme (_, _), actual as T.TypeScheme (_, _), origin) = let val ictx = { context = ctx , level = 0 } - val (tyE, tyargsE) = instantiate (ictx, span, expected) - val (tyA, tyargsA) = instantiate (ictx, span, actual) - fun onMismatch expected + val (tyE, _) = instantiate (ictx, span, expected) + val (tyA, _) = instantiate (ictx, span, actual) + fun onMismatch (_ (* expected *)) = case origin of T.VALDESC_COMMENT => (case #valDescInComments (#languageOptions ctx) of LanguageOptions.ERROR => ( Message.error (#messageHandler ctx, [span], "type", "value description mismatch") @@ -2508,43 +2506,43 @@ local onMismatch expected | equalTy (T.FnType (_, ty1, ty2), T.FnType (_, ty1', ty2')) = equalTy (ty1, ty1') andalso equalTy (ty2, ty2') - | equalTy (ty1, ty2) = onMismatch ty1 + | equalTy (ty1, _) = onMismatch ty1 in ignore (equalTy (tyE, tyA)) end - fun checkExp (ctx : Context, env, T.SConExp _) : unit = () - | checkExp (ctx, env, T.VarExp _) = () - | checkExp (ctx, env, T.RecordExp (span, fields)) = List.app (fn (label, exp) => checkExp (ctx, env, exp)) fields - | checkExp (ctx, env, T.RecordExtExp { sourceSpan, fields, baseExp, baseTy }) - = ( List.app (fn (label, exp) => checkExp (ctx, env, exp)) fields + fun checkExp (_ : Context, _, T.SConExp _) : unit = () + | checkExp (_, _, T.VarExp _) = () + | checkExp (ctx, env, T.RecordExp (_, fields)) = List.app (fn (_, exp) => checkExp (ctx, env, exp)) fields + | checkExp (ctx, env, T.RecordExtExp { sourceSpan = _, fields, baseExp, baseTy = _ }) + = ( List.app (fn (_, exp) => checkExp (ctx, env, exp)) fields ; checkExp (ctx, env, baseExp) ) - | checkExp (ctx, env, T.LetInExp (span, decs, exp)) = (checkDecs (ctx, env, decs); checkExp (ctx, env, exp)) - | checkExp (ctx, env, T.AppExp (span, e1, e2)) = (checkExp (ctx, env, e1); checkExp (ctx, env, e2)) - | checkExp (ctx, env, T.TypedExp (span, e, ty)) = checkExp (ctx, env, e) - | checkExp (ctx, env, T.HandleExp (span, exp, match, ty)) = (checkExp (ctx, env, exp); checkMatch (ctx, env, match)) - | checkExp (ctx, env, T.RaiseExp (span, ty, exp)) = checkExp (ctx, env, exp) - | checkExp (ctx, env, T.IfThenElseExp (span, e1, e2, e3)) = (checkExp (ctx, env, e1); checkExp (ctx, env, e2); checkExp (ctx, env, e3)) - | checkExp (ctx, env, T.CaseExp { sourceSpan, subjectExp, subjectTy, matches, matchType, resultTy }) = (checkExp (ctx, env, subjectExp); checkMatch (ctx, env, matches)) - | checkExp (ctx, env, T.FnExp (span, vid, ty, exp)) = checkExp (ctx, env, exp) - | checkExp (ctx, env, T.ProjectionExp _) = () - | checkExp (ctx, env, T.ListExp (span, elems, ty)) = Vector.app (fn e => checkExp (ctx, env, e)) elems - | checkExp (ctx, env, T.VectorExp (span, elems, ty)) = Vector.app (fn e => checkExp (ctx, env, e)) elems - | checkExp (ctx, env, T.PrimExp (span, _, _, args)) = Vector.app (fn e => checkExp (ctx, env, e)) args - | checkExp (ctx, env, T.BogusExp _) = () - and checkDec (ctx, env, T.ValDec (span, valbinds)) = List.app (fn valbind => checkValBind (ctx, env, valbind)) valbinds - | checkDec (ctx, env, T.RecValDec (span, valbinds)) = List.app (fn valbind => checkValBind (ctx, env, valbind)) valbinds - | checkDec (ctx, env, T.IgnoreDec (span, exp, ty)) = checkExp (ctx, env, exp) - | checkDec (ctx, env, T.TypeDec _) = () - | checkDec (ctx, env, T.DatatypeDec _) = () - | checkDec (ctx, env, T.ExceptionDec _) = () - | checkDec (ctx, env, T.OverloadDec (span, class, name, map)) = Syntax.OverloadKeyMap.app (fn exp => checkExp (ctx, env, exp)) map - | checkDec (ctx, env, T.EqualityDec (span, tyvars, tyname, exp)) = checkExp (ctx, T.TyVarSet.addList (env, tyvars), exp) + | checkExp (ctx, env, T.LetInExp (_, decs, exp)) = (checkDecs (ctx, env, decs); checkExp (ctx, env, exp)) + | checkExp (ctx, env, T.AppExp (_, e1, e2)) = (checkExp (ctx, env, e1); checkExp (ctx, env, e2)) + | checkExp (ctx, env, T.TypedExp (_, e, _)) = checkExp (ctx, env, e) + | checkExp (ctx, env, T.HandleExp (_, exp, match, _)) = (checkExp (ctx, env, exp); checkMatch (ctx, env, match)) + | checkExp (ctx, env, T.RaiseExp (_, _, exp)) = checkExp (ctx, env, exp) + | checkExp (ctx, env, T.IfThenElseExp (_, e1, e2, e3)) = (checkExp (ctx, env, e1); checkExp (ctx, env, e2); checkExp (ctx, env, e3)) + | checkExp (ctx, env, T.CaseExp { sourceSpan = _, subjectExp, subjectTy = _, matches, matchType = _, resultTy = _ }) = (checkExp (ctx, env, subjectExp); checkMatch (ctx, env, matches)) + | checkExp (ctx, env, T.FnExp (_, _, _, exp)) = checkExp (ctx, env, exp) + | checkExp (_, _, T.ProjectionExp _) = () + | checkExp (ctx, env, T.ListExp (_, elems, _)) = Vector.app (fn e => checkExp (ctx, env, e)) elems + | checkExp (ctx, env, T.VectorExp (_, elems, _)) = Vector.app (fn e => checkExp (ctx, env, e)) elems + | checkExp (ctx, env, T.PrimExp (_, _, _, args)) = Vector.app (fn e => checkExp (ctx, env, e)) args + | checkExp (_, _, T.BogusExp _) = () + and checkDec (ctx, env, T.ValDec (_, valbinds)) = List.app (fn valbind => checkValBind (ctx, env, valbind)) valbinds + | checkDec (ctx, env, T.RecValDec (_, valbinds)) = List.app (fn valbind => checkValBind (ctx, env, valbind)) valbinds + | checkDec (ctx, env, T.IgnoreDec (_, exp, _)) = checkExp (ctx, env, exp) + | checkDec (_, _, T.TypeDec _) = () + | checkDec (_, _, T.DatatypeDec _) = () + | checkDec (_, _, T.ExceptionDec _) = () + | checkDec (ctx, env, T.OverloadDec (_, _, _, map)) = Syntax.OverloadKeyMap.app (fn exp => checkExp (ctx, env, exp)) map + | checkDec (ctx, env, T.EqualityDec (_, tyvars, _, exp)) = checkExp (ctx, T.TyVarSet.addList (env, tyvars), exp) | checkDec (ctx, env, T.ValDescDec { sourceSpan, expected, actual, origin }) = checkValDesc (ctx, env, sourceSpan, expected, actual, origin) - | checkDec (ctx, env, T.ESImportDec { sourceSpan, pure, specs, moduleName }) = () + | checkDec (_, _, T.ESImportDec _) = () and checkDecs (ctx, env, decs) = List.app (fn dec => checkDec (ctx, env, dec)) decs - and checkMatch (ctx, env, matches) = List.app (fn (pat, exp) => checkExp (ctx, env, exp)) matches + and checkMatch (ctx, env, matches) = List.app (fn (_, exp) => checkExp (ctx, env, exp)) matches and checkValBind (ctx, env, T.TupleBind (_, _, exp)) = checkExp (ctx, env, exp) - | checkValBind (ctx, env, T.PolyVarBind (span, _, T.TypeScheme (tyvars, ty), exp)) = checkExp (ctx, T.TyVarSet.addList (env, List.map #1 tyvars), exp) + | checkValBind (ctx, env, T.PolyVarBind (_, _, T.TypeScheme (tyvars, _), exp)) = checkExp (ctx, T.TyVarSet.addList (env, List.map #1 tyvars), exp) in val checkTypeDescriptionInDecs = checkDecs end @@ -2566,11 +2564,11 @@ fun checkTyScope (ctx, tvset : T.TyVarSet.set, tynameset : T.TyNameSet.set) () else emitError (ctx, [span], "type variable scope violation: " ^ TypedSyntax.PrettyPrint.print_TyVar tv) - | goTy (T.AnonymousTyVar (span, ref (T.Link ty))) = goTy ty + | goTy (T.AnonymousTyVar (_, ref (T.Link ty))) = goTy ty | goTy (T.AnonymousTyVar (span, tv as ref (T.Unbound _))) = emitError (ctx, [span], "type variable scope violation: " ^ TypedSyntax.PrettyPrint.print_AnonymousTyVar tv) - | goTy (T.RecordType (span, fields)) = Syntax.LabelMap.app goTy fields - | goTy (T.RecordExtType (span, fields, baseTy)) = ( Syntax.LabelMap.app goTy fields; goTy baseTy ) + | goTy (T.RecordType (_, fields)) = Syntax.LabelMap.app goTy fields + | goTy (T.RecordExtType (_, fields, baseTy)) = ( Syntax.LabelMap.app goTy fields; goTy baseTy ) | goTy (T.TyCon (span, tyargs, tyname)) = ( if T.TyNameSet.member (tynameset, tyname) then () @@ -2578,80 +2576,80 @@ fun checkTyScope (ctx, tvset : T.TyVarSet.set, tynameset : T.TyNameSet.set) emitError (ctx, [span], "type constructor scope violation: " ^ TypedSyntax.PrettyPrint.print_TyName tyname) ; List.app goTy tyargs ) - | goTy (T.FnType (span, ty1, ty2)) = ( goTy ty1; goTy ty2 ) + | goTy (T.FnType (_, ty1, ty2)) = ( goTy ty1; goTy ty2 ) fun goTypeScheme (T.TypeScheme (typarams, ty)) = #goTy (checkTyScope (ctx, T.TyVarSet.addList (tvset, List.map #1 typarams), tynameset)) ty fun goPat (T.WildcardPat _) = () | goPat (T.SConPat _) = () | goPat (T.VarPat (_, _, ty)) = goTy ty - | goPat (T.RecordPat { sourceSpan, fields, ellipsis, wholeRecordType }) - = ( List.app (fn (label, pat) => goPat pat) fields + | goPat (T.RecordPat { sourceSpan = _, fields, ellipsis, wholeRecordType }) + = ( List.app (fn (_, pat) => goPat pat) fields ; Option.app goPat ellipsis ; goTy wholeRecordType ) - | goPat (T.ConPat { sourceSpan, longvid, payload, tyargs, valueConstructorInfo }) = ( List.app goTy tyargs - ; Option.app (fn (ty, pat) => (goTy ty; goPat pat)) payload - ) - | goPat (T.TypedPat (span, pat, ty)) = ( goTy ty; goPat pat ) - | goPat (T.LayeredPat (span, vid, ty, pat)) = ( goTy ty; goPat pat ) - | goPat (T.VectorPat (span, pats, ellipsis, elemTy)) = ( goTy elemTy; Vector.app goPat pats ) - fun goExp (T.SConExp (span, scon, ty)) = goTy ty - | goExp (T.VarExp (span, longvid, ids, tyargs)) = List.app (fn (ty, cts) => goTy ty) tyargs - | goExp (T.RecordExp (span, fields)) = List.app (fn (label, exp) => goExp exp) fields - | goExp (T.RecordExtExp { sourceSpan, fields, baseExp, baseTy }) - = ( List.app (fn (label, exp) => goExp exp) fields + | goPat (T.ConPat { sourceSpan = _, longvid = _, payload, tyargs, valueConstructorInfo = _ }) = ( List.app goTy tyargs + ; Option.app (fn (ty, pat) => (goTy ty; goPat pat)) payload + ) + | goPat (T.TypedPat (_, pat, ty)) = ( goTy ty; goPat pat ) + | goPat (T.LayeredPat (_, _, ty, pat)) = ( goTy ty; goPat pat ) + | goPat (T.VectorPat (_, pats, _, elemTy)) = ( goTy elemTy; Vector.app goPat pats ) + fun goExp (T.SConExp (_, _, ty)) = goTy ty + | goExp (T.VarExp (_, _, _, tyargs)) = List.app (fn (ty, _) => goTy ty) tyargs + | goExp (T.RecordExp (_, fields)) = List.app (fn (_, exp) => goExp exp) fields + | goExp (T.RecordExtExp { sourceSpan = _, fields, baseExp, baseTy }) + = ( List.app (fn (_, exp) => goExp exp) fields ; goExp baseExp ; goTy baseTy ) - | goExp (T.LetInExp (span, decs, exp)) = let val tynameset = goDecs decs - val { goExp, ... } = checkTyScope (ctx, tvset, tynameset) - in goExp exp - end - | goExp (T.AppExp (span, exp1, exp2)) = ( goExp exp1; goExp exp2 ) - | goExp (T.TypedExp (span, exp, ty)) = ( goExp exp; goTy ty ) - | goExp (T.HandleExp (span, exp, matches, resultTy)) = ( goExp exp; goTy resultTy; List.app (fn (pat, exp) => (goPat pat; goExp exp)) matches ) - | goExp (T.RaiseExp (span, ty, exp)) = ( goTy ty; goExp exp ) - | goExp (T.IfThenElseExp (span, exp1, exp2, exp3)) = ( goExp exp1; goExp exp2; goExp exp3 ) + | goExp (T.LetInExp (_, decs, exp)) = let val tynameset = goDecs decs + val { goExp, ... } = checkTyScope (ctx, tvset, tynameset) + in goExp exp + end + | goExp (T.AppExp (_, exp1, exp2)) = ( goExp exp1; goExp exp2 ) + | goExp (T.TypedExp (_, exp, ty)) = ( goExp exp; goTy ty ) + | goExp (T.HandleExp (_, exp, matches, resultTy)) = ( goExp exp; goTy resultTy; List.app (fn (pat, exp) => (goPat pat; goExp exp)) matches ) + | goExp (T.RaiseExp (_, ty, exp)) = ( goTy ty; goExp exp ) + | goExp (T.IfThenElseExp (_, exp1, exp2, exp3)) = ( goExp exp1; goExp exp2; goExp exp3 ) | goExp (T.CaseExp { sourceSpan = _, subjectExp, subjectTy, matches, matchType = _, resultTy }) = ( goExp subjectExp; goTy subjectTy; goTy resultTy; List.app (fn (pat, exp) => (goPat pat; goExp exp)) matches ) - | goExp (T.FnExp (span, vid, ty, exp)) = ( goTy ty; goExp exp ) - | goExp (T.ProjectionExp { sourceSpan, label, recordTy, fieldTy }) = ( goTy recordTy; goTy fieldTy ) - | goExp (T.ListExp (span, xs, ty)) = ( Vector.app goExp xs ; goTy ty ) - | goExp (T.VectorExp (span, xs, ty)) = ( Vector.app goExp xs ; goTy ty ) - | goExp (T.PrimExp (span, primOp, tyargs, args)) = ( Vector.app goTy tyargs ; Vector.app goExp args ) - | goExp (T.BogusExp (span, ty)) = goTy ty - and goDec (T.ValDec (span, valbinds)) = ( List.app goValBind valbinds + | goExp (T.FnExp (_, _, ty, exp)) = ( goTy ty; goExp exp ) + | goExp (T.ProjectionExp { sourceSpan = _, label = _, recordTy, fieldTy }) = ( goTy recordTy; goTy fieldTy ) + | goExp (T.ListExp (_, xs, ty)) = ( Vector.app goExp xs ; goTy ty ) + | goExp (T.VectorExp (_, xs, ty)) = ( Vector.app goExp xs ; goTy ty ) + | goExp (T.PrimExp (_, _, tyargs, args)) = ( Vector.app goTy tyargs ; Vector.app goExp args ) + | goExp (T.BogusExp (_, ty)) = goTy ty + and goDec (T.ValDec (_, valbinds)) = ( List.app goValBind valbinds + ; tynameset + ) + | goDec (T.RecValDec (_, valbinds)) = ( List.app goValBind valbinds ; tynameset ) - | goDec (T.RecValDec (span, valbinds)) = ( List.app goValBind valbinds + | goDec (T.IgnoreDec (_, exp, ty)) = ( goExp exp ; goTy ty ; tynameset ) + | goDec (T.TypeDec (_, typbinds)) = let fun goTypBind (T.TypBind (_, tyvars, _, ty)) = let val { goTy, ... } = checkTyScope (ctx, T.TyVarSet.addList (tvset, tyvars), tynameset) + in goTy ty + end + in List.app goTypBind typbinds + ; tynameset + end + | goDec (T.DatatypeDec (_, datbinds)) = let val tynameset = List.foldl (fn (T.DatBind (_, _, tyname, _, _), tynameset) => T.TyNameSet.add (tynameset, tyname)) tynameset datbinds + fun goDatBind (T.DatBind (_, tyvars, _, conbinds, _)) + = let val { goTy, ... } = checkTyScope (ctx, T.TyVarSet.addList (tvset, tyvars), tynameset) + fun goConBind (T.ConBind (_, _, optTy, _)) = Option.app goTy optTy + in List.app goConBind conbinds + end + in List.app goDatBind datbinds ; tynameset - ) - | goDec (T.IgnoreDec (span, exp, ty)) = ( goExp exp ; goTy ty ; tynameset ) - | goDec (T.TypeDec (span, typbinds)) = let fun goTypBind (T.TypBind (span, tyvars, tycon, ty)) = let val { goTy, ... } = checkTyScope (ctx, T.TyVarSet.addList (tvset, tyvars), tynameset) - in goTy ty - end - in List.app goTypBind typbinds + end + | goDec (T.ExceptionDec (_, exbinds)) = ( List.app (fn T.ExBind (_, _, optTy) => Option.app goTy optTy + | T.ExReplication (_, _, _, optTy) => Option.app goTy optTy + ) exbinds ; tynameset - end - | goDec (T.DatatypeDec (span, datbinds)) = let val tynameset = List.foldl (fn (T.DatBind (span, _, tyname, _, _), tynameset) => T.TyNameSet.add (tynameset, tyname)) tynameset datbinds - fun goDatBind (T.DatBind (span, tyvars, tyname, conbinds, _)) - = let val { goTy, ... } = checkTyScope (ctx, T.TyVarSet.addList (tvset, tyvars), tynameset) - fun goConBind (T.ConBind (span, vid, optTy, info)) = Option.app goTy optTy - in List.app goConBind conbinds - end - in List.app goDatBind datbinds - ; tynameset - end - | goDec (T.ExceptionDec (span, exbinds)) = ( List.app (fn T.ExBind (span, vid, optTy) => Option.app goTy optTy - | T.ExReplication (span, vid, longvid, optTy) => Option.app goTy optTy - ) exbinds - ; tynameset - ) - | goDec (T.OverloadDec (span, class, tyname, map)) = ( if T.TyNameSet.member (tynameset, tyname) then - () - else - emitError (ctx, [span], "type constructor scope violation: " ^ TypedSyntax.PrettyPrint.print_TyName tyname) - ; Syntax.OverloadKeyMap.app goExp map - ; tynameset - ) + ) + | goDec (T.OverloadDec (span, _, tyname, map)) = ( if T.TyNameSet.member (tynameset, tyname) then + () + else + emitError (ctx, [span], "type constructor scope violation: " ^ TypedSyntax.PrettyPrint.print_TyName tyname) + ; Syntax.OverloadKeyMap.app goExp map + ; tynameset + ) | goDec (T.EqualityDec (span, typarams, tyname, exp)) = ( if T.TyNameSet.member (tynameset, tyname) then () else @@ -2659,12 +2657,12 @@ fun checkTyScope (ctx, tvset : T.TyVarSet.set, tynameset : T.TyNameSet.set) ; #goExp (checkTyScope (ctx, T.TyVarSet.addList (tvset, typarams), tynameset)) exp ; tynameset ) - | goDec (T.ValDescDec { sourceSpan, expected = T.TypeScheme (tyvars, ty), actual = T.TypeScheme (tyvars', ty'), origin }) + | goDec (T.ValDescDec { sourceSpan = _, expected = T.TypeScheme (tyvars, ty), actual = T.TypeScheme (tyvars', ty'), origin = _ }) = ( #goTy (checkTyScope (ctx, T.TyVarSet.addList (tvset, List.map #1 tyvars), tynameset)) ty ; #goTy (checkTyScope (ctx, T.TyVarSet.addList (tvset, List.map #1 tyvars'), tynameset)) ty' ; tynameset ) - | goDec (T.ESImportDec { sourceSpan, pure, specs, moduleName }) + | goDec (T.ESImportDec { sourceSpan = _, pure = _, specs, moduleName = _ }) = ( List.app (fn (_, _, ty) => goTy ty) specs ; tynameset ) @@ -2672,41 +2670,41 @@ fun checkTyScope (ctx, tvset : T.TyVarSet.set, tynameset : T.TyNameSet.set) in goDec dec end) tynameset decs - and goValBind (T.TupleBind (span, binds, exp)) = ( List.app (fn (vid, ty) => goTy ty) binds - ; goExp exp - ) - | goValBind (T.PolyVarBind (span, vid, T.TypeScheme (typarams, ty), exp)) + and goValBind (T.TupleBind (_, binds, exp)) = ( List.app (fn (_, ty) => goTy ty) binds + ; goExp exp + ) + | goValBind (T.PolyVarBind (_, _, T.TypeScheme (typarams, ty), exp)) = let val { goTy, goExp, ... } = checkTyScope (ctx, T.TyVarSet.addList (tvset, List.map #1 typarams), tynameset) in goTy ty ; goExp exp end fun goStrExp (T.StructExp _) = tynameset | goStrExp (T.StrIdExp _) = tynameset - | goStrExp (T.PackedStrExp { sourceSpan, strExp, payloadTypes, packageSig }) = let val _ = goStrExp strExp : T.TyNameSet.set - in List.foldl (fn ({ tyname, ... }, set) => T.TyNameSet.add (set, tyname)) tynameset (#bound packageSig) - end - | goStrExp (T.FunctorAppExp { sourceSpan, funId, argumentTypes, argumentStr, packageSig }) + | goStrExp (T.PackedStrExp { sourceSpan = _, strExp, payloadTypes = _, packageSig }) = let val _ = goStrExp strExp : T.TyNameSet.set + in List.foldl (fn ({ tyname, ... }, set) => T.TyNameSet.add (set, tyname)) tynameset (#bound packageSig) + end + | goStrExp (T.FunctorAppExp { sourceSpan = _, funId = _, argumentTypes = _, argumentStr, packageSig }) = let val tynameset = goStrExp argumentStr (* TODO: Check argumentTypes *) in List.foldl (fn ({ tyname, ... }, set) => T.TyNameSet.add (set, tyname)) tynameset (#bound packageSig) end - | goStrExp (T.LetInStrExp (span, strdecs, strexp)) = let val tynameset = goStrDecs strdecs - val { goStrExp, ... } = checkTyScope (ctx, tvset, tynameset) - in goStrExp strexp - end + | goStrExp (T.LetInStrExp (_, strdecs, strexp)) = let val tynameset = goStrDecs strdecs + val { goStrExp, ... } = checkTyScope (ctx, tvset, tynameset) + in goStrExp strexp + end and goStrDec (T.CoreDec (_, dec)) = goDec dec - | goStrDec (T.StrBindDec (_, strid, strexp, { s, bound })) = List.foldl (fn ({ tyname, ... }, set) => T.TyNameSet.add (set, tyname)) (goStrExp strexp) bound + | goStrDec (T.StrBindDec (_, _, strexp, { s = _, bound })) = List.foldl (fn ({ tyname, ... }, set) => T.TyNameSet.add (set, tyname)) (goStrExp strexp) bound and goStrDecs decs = List.foldl (fn (dec, tynameset) => let val { goStrDec, ... } = checkTyScope (ctx, tvset, tynameset) in goStrDec dec end) tynameset decs - fun goFunExp (tynames, strid, s, strexp) = let val tynameset' = List.foldl (fn ({ tyname, ...}, set) => T.TyNameSet.add (set, tyname)) tynameset tynames - val { goStrExp, ... } = checkTyScope (ctx, tvset, tynameset') - val _ = goStrExp strexp : T.TyNameSet.set - in tynameset - end + fun goFunExp (tynames, _, _, strexp) = let val tynameset' = List.foldl (fn ({ tyname, ...}, set) => T.TyNameSet.add (set, tyname)) tynameset tynames + val { goStrExp, ... } = checkTyScope (ctx, tvset, tynameset') + val _ = goStrExp strexp : T.TyNameSet.set + in tynameset + end fun goTopDec (T.StrDec dec) = goStrDec dec - | goTopDec (T.FunDec (funid, funexp)) = goFunExp funexp + | goTopDec (T.FunDec (_, funexp)) = goFunExp funexp fun goTopDecs decs = List.foldl (fn (dec, tynameset) => let val { goTopDec, ... } = checkTyScope (ctx, tvset, tynameset) in goTopDec dec end) @@ -2746,7 +2744,7 @@ fun mergeQSignature (s1 : T.QSignature, s2 : T.QSignature) : T.QSignature } fun canonicalOrderForQSignature ({ s, bound } : T.QSignature) : T.TyName list - = let val bound' = T.TyNameMap.mapi (fn (tyname, { arity, admitsEquality, longtycon }) => Option.getOpt (canonicalPathForTyName (s, tyname), longtycon)) bound + = let val bound' = T.TyNameMap.mapi (fn (tyname, { arity = _, admitsEquality = _, longtycon }) => Option.getOpt (canonicalPathForTyName (s, tyname), longtycon)) bound fun insert ([], key, value) = [(key, value)] | insert (xs0 as ((k, v) :: xs), key, value) = case Syntax.LongTyCon.compare (k, key) of LESS => (k, v) :: insert (xs, key, value) @@ -2754,10 +2752,10 @@ fun canonicalOrderForQSignature ({ s, bound } : T.QSignature) : T.TyName list | EQUAL => (key, value) :: xs (* cannot happen *) in List.map #2 (T.TyNameMap.foldli (fn (tyname, longtycon, acc) => insert (acc, longtycon, tyname)) [] bound') end -and canonicalPathForTyName ({ valMap, tyConMap, strMap } : T.Signature, tyname : T.TyName) : Syntax.LongTyCon option - = let val t = Syntax.TyConMap.filter (fn { typeFunction = T.TypeFunction (tyvars, ty), valEnv } => +and canonicalPathForTyName ({ valMap = _, tyConMap, strMap } : T.Signature, tyname : T.TyName) : Syntax.LongTyCon option + = let val t = Syntax.TyConMap.filter (fn { typeFunction = T.TypeFunction (tyvars, ty), valEnv = _ } => case ty of - T.TyCon (span, tyargs, tyname') => + T.TyCon (_, tyargs, tyname') => T.eqTyName (tyname, tyname') andalso ListPair.allEq (fn (tv, T.TyVar (_, tv')) => T.eqUTyVar (tv, tv') | _ => false ) (tyvars, tyargs) @@ -2811,7 +2809,7 @@ fun applySubstTyConInSig (ctx : Context, subst : T.TypeFunction T.TyNameMap.map) in goSig end -fun refreshTyNameInTy (ctx : Context, subst : T.TyName T.TyNameMap.map) : T.Ty -> T.Ty +fun refreshTyNameInTy (_ : Context, subst : T.TyName T.TyNameMap.map) : T.Ty -> T.Ty = let fun goTy (ty as T.TyVar _) = ty | goTy (ty as T.AnonymousTyVar _) = ty | goTy (T.RecordType (span, fields)) = T.RecordType (span, Syntax.LabelMap.map goTy fields) @@ -2840,13 +2838,13 @@ fun refreshTyNameInSig (ctx : Context, subst : T.TyName T.TyNameMap.map) : T.Sig end fun checkEquality (ctx : Context, env : ('val,'str) Env', tyvars : T.TyVarSet.set) : T.Ty -> bool - = let fun goTy (T.TyVar (span, tv)) = if T.TyVarSet.member (tyvars, tv) then - true - else - T.tyVarAdmitsEquality tv + = let fun goTy (T.TyVar (_, tv)) = if T.TyVarSet.member (tyvars, tv) then + true + else + T.tyVarAdmitsEquality tv | goTy (T.AnonymousTyVar _) = false (* should be an error *) - | goTy (T.RecordType (span, fields)) = Syntax.LabelMap.all goTy fields - | goTy (T.RecordExtType (span, fields, baseTy)) = Syntax.LabelMap.all goTy fields andalso goTy baseTy + | goTy (T.RecordType (_, fields)) = Syntax.LabelMap.all goTy fields + | goTy (T.RecordExtType (_, fields, baseTy)) = Syntax.LabelMap.all goTy fields andalso goTy baseTy | goTy (T.TyCon (span, tyargs, tyname)) = isRefOrArray tyname orelse (let val { admitsEquality, ... } = lookupTyNameInEnv (ctx, env, span, tyname) in admitsEquality andalso List.all goTy tyargs @@ -2863,7 +2861,7 @@ fun lookupLongTyConInQSignature (ctx, span, s : T.QSignature, longtycon) : T.Typ SOME tystr => tystr | NONE => emitFatalError (ctx, [span], "unknown type constructor '" ^ name ^ "'") end -fun getTypeNameFromTypeStructure (ctx, { typeFunction = T.TypeFunction (tyvars, T.TyCon (_, tyargs, tyname)), ... } : T.TypeStructure) : (T.TyName * int) option +fun getTypeNameFromTypeStructure (_ (* ctx *), { typeFunction = T.TypeFunction (tyvars, T.TyCon (_, tyargs, tyname)), ... } : T.TypeStructure) : (T.TyName * int) option = let val arity = List.length tyvars in if List.length tyargs = arity then if ListPair.allEq (fn (tv, T.TyVar (_, tv')) => tv = tv' | _ => false) (tyvars, tyargs) then @@ -2875,7 +2873,7 @@ fun getTypeNameFromTypeStructure (ctx, { typeFunction = T.TypeFunction (tyvars, end | getTypeNameFromTypeStructure _ = NONE -fun evalSignature (ctx : Context, env : SigEnv, S.BasicSigExp (span, specs)) : T.QSignature +fun evalSignature (ctx : Context, env : SigEnv, S.BasicSigExp (_, specs)) : T.QSignature = evalSpecs(ctx, env, specs) | evalSignature(ctx, env, S.SigIdExp(span, sigid as Syntax.MkSigId name)) = (case Syntax.SigIdMap.find(#sigMap env, sigid) of @@ -2918,10 +2916,10 @@ fun evalSignature (ctx : Context, env : SigEnv, S.BasicSigExp (span, specs)) : T | NONE => emitFatalError (ctx, [span], "type realisation against a rigid type") end and evalSpecs (ctx : Context, env : SigEnv, specs) : T.QSignature - = List.foldl (fn (spec, s) => let val env' = addSignatureToEnv (env, #s s, T.TyNameMap.map (fn { arity, admitsEquality, longtycon } => { arity = arity, admitsEquality = admitsEquality, overloadClass = NONE }) (#bound s)) + = List.foldl (fn (spec, s) => let val env' = addSignatureToEnv (env, #s s, T.TyNameMap.map (fn { arity, admitsEquality, longtycon = _ } => { arity = arity, admitsEquality = admitsEquality, overloadClass = NONE }) (#bound s)) in mergeQSignature(s, addSpec(ctx, env', spec)) end) { s = emptySignature, bound = T.TyNameMap.empty } specs -and addSpec (ctx : Context, env : SigEnv, S.ValDesc (span, descs)) : T.QSignature +and addSpec (ctx : Context, env : SigEnv, S.ValDesc (_, descs)) : T.QSignature = { s = { valMap = List.foldl (fn ((vid, ty), valMap) => let val tvs = PostParsing.freeTyVarsInTy(Syntax.TyVarSet.empty, ty) val tvs = Syntax.TyVarSet.foldr (fn (tv, m) => Syntax.TyVarMap.insert(m, tv, genTyVar(ctx, tv))) Syntax.TyVarMap.empty tvs val env' = { valMap = #valMap env @@ -2940,7 +2938,7 @@ and addSpec (ctx : Context, env : SigEnv, S.ValDesc (span, descs)) : T.QSignatur } , bound = TypedSyntax.TyNameMap.empty } - | addSpec(ctx, env, S.TypeDesc(span, descs)) + | addSpec (ctx, _, S.TypeDesc (span, descs)) = List.foldl (fn ((tyvars, tycon), s) => let val tyname = newTyName(ctx, tycon) val tyvars = List.map (fn tv => genTyVar(ctx, tv)) tyvars val tystr = { typeFunction = T.TypeFunction (tyvars, T.TyCon (span, List.map (fn tv => T.TyVar (span, tv)) tyvars, tyname)) @@ -2964,7 +2962,7 @@ and addSpec (ctx : Context, env : SigEnv, S.ValDesc (span, descs)) : T.QSignatur } , bound = TypedSyntax.TyNameMap.empty } descs - | addSpec(ctx, env, S.EqtypeDesc(span, descs)) + | addSpec (ctx, _, S.EqtypeDesc (span, descs)) = List.foldl (fn ((tyvars, tycon), s) => let val tyname = newTyName(ctx, tycon) val tyvars = List.map (fn tv => genTyVar(ctx, tv)) tyvars val tystr = { typeFunction = T.TypeFunction (tyvars, T.TyCon (span, List.map (fn tv => T.TyVar (span, tv)) tyvars, tyname)) @@ -3010,7 +3008,7 @@ and addSpec (ctx : Context, env : SigEnv, S.ValDesc (span, descs)) : T.QSignatur end ) (Syntax.TyConMap.empty, TypedSyntax.TyNameMap.empty, []) descs val env' = mergeEnv(env, envWithTyConEnv(partialTyConMap, tyNameMap)) - val withtypeMap = List.foldl (fn (S.TypBind (span, tyvars, tycon, ty), tyConMap) => + val withtypeMap = List.foldl (fn (S.TypBind (_, tyvars, tycon, ty), tyConMap) => let val tyvars = List.map (fn tv => (tv, genTyVar(ctx, tv))) tyvars val ty = let val env = { valMap = #valMap env' , tyConMap = #tyConMap env' @@ -3038,8 +3036,8 @@ and addSpec (ctx : Context, env : SigEnv, S.ValDesc (span, descs)) : T.QSignatur , funMap = #funMap env' , boundTyVars = List.foldl Syntax.TyVarMap.insert' (#boundTyVars env') tyvarPairs } - val allConstructors = List.foldl (fn (Syntax.ConBind (span, vid, _), set) => Syntax.VIdSet.add (set, vid)) Syntax.VIdSet.empty condescs - val constructorsWithPayload = List.foldl (fn (Syntax.ConBind (span, vid, optTy), set) => if Option.isSome optTy then Syntax.VIdSet.add (set, vid) else set) Syntax.VIdSet.empty condescs + val allConstructors = List.foldl (fn (Syntax.ConBind (_, vid, _), set) => Syntax.VIdSet.add (set, vid)) Syntax.VIdSet.empty condescs + val constructorsWithPayload = List.foldl (fn (Syntax.ConBind (_, vid, optTy), set) => if Option.isSome optTy then Syntax.VIdSet.add (set, vid) else set) Syntax.VIdSet.empty condescs val representation = case condescs of [S.ConBind (_, _, SOME _)] => Syntax.REP_ALIAS | [S.ConBind (_, _, NONE)] => Syntax.REP_UNIT @@ -3102,26 +3100,26 @@ and addSpec (ctx : Context, env : SigEnv, S.ValDesc (span, descs)) : T.QSignatur } , bound = TypedSyntax.TyNameMap.empty } - | addSpec(ctx, env, S.StrDesc(span, descs)) = let val strMap = List.foldl (fn ((strid, sigexp), m) => Syntax.StrIdMap.insert(m, strid, evalSignature(ctx, env, sigexp))) Syntax.StrIdMap.empty descs - in { s = { valMap = Syntax.VIdMap.empty - , tyConMap = Syntax.TyConMap.empty - , strMap = Syntax.StrIdMap.map (fn { s, bound } => T.MkSignature s) strMap - } - , bound = Syntax.StrIdMap.foldli (fn (strid, { bound, ... }, map) => - TypedSyntax.TyNameMap.unionWith #2 (map, TypedSyntax.TyNameMap.map (fn { arity, admitsEquality, longtycon = Syntax.MkQualified (strids, tycon) } => - { arity = arity - , admitsEquality = admitsEquality - , longtycon = Syntax.MkQualified (strid :: strids, tycon) - } - ) bound)) TypedSyntax.TyNameMap.empty strMap - } - end - | addSpec(ctx, env, S.Include(span, sigexp)) = evalSignature(ctx, env, sigexp) + | addSpec (ctx, env, S.StrDesc (_, descs)) = let val strMap = List.foldl (fn ((strid, sigexp), m) => Syntax.StrIdMap.insert (m, strid, evalSignature (ctx, env, sigexp))) Syntax.StrIdMap.empty descs + in { s = { valMap = Syntax.VIdMap.empty + , tyConMap = Syntax.TyConMap.empty + , strMap = Syntax.StrIdMap.map (fn { s, bound = _ } => T.MkSignature s) strMap + } + , bound = Syntax.StrIdMap.foldli (fn (strid, { bound, ... }, map) => + TypedSyntax.TyNameMap.unionWith #2 (map, TypedSyntax.TyNameMap.map (fn { arity, admitsEquality, longtycon = Syntax.MkQualified (strids, tycon) } => + { arity = arity + , admitsEquality = admitsEquality + , longtycon = Syntax.MkQualified (strid :: strids, tycon) + } + ) bound)) TypedSyntax.TyNameMap.empty strMap + } + end + | addSpec (ctx, env, S.Include (_, sigexp)) = evalSignature (ctx, env, sigexp) | addSpec(ctx, env, S.Sharing(span, specs, longtycon0 :: longtycons)) = let val s = evalSpecs(ctx, env, specs) in shareLongTyCons(ctx, span, s, longtycon0, longtycons) end - | addSpec(ctx, env, S.Sharing(span, specs, [])) = emitFatalError(ctx, [span], "sharing: empty longtycons (internal error)") + | addSpec (ctx, _, S.Sharing (span, _, [])) = emitFatalError (ctx, [span], "sharing: empty longtycons (internal error)") | addSpec(ctx, env, S.SharingStructure(span, specs, longstrids)) = let val s = evalSpecs(ctx, env, specs) val strs = List.map (fn Syntax.MkQualified(strids, strid) => @@ -3142,7 +3140,7 @@ and addSpec (ctx : Context, env : SigEnv, S.ValDesc (span, descs)) : T.QSignatur | doStructure(s, []) = s in doStructure(s, strs) end - | addSpec(ctx, env, S.TypeAliasDesc(span, descs)) + | addSpec (ctx, env, S.TypeAliasDesc (_, descs)) = { s = { valMap = Syntax.VIdMap.empty , tyConMap = List.foldl (fn ((tyvars, tycon, ty), tyConMap) => let val tyvars = List.map (fn tv => (tv, genTyVar(ctx, tv))) tyvars @@ -3221,14 +3219,14 @@ and collectLongTyCons (ctx, strids : Syntax.StrId list, { valMap = _, tyConMap, ) set strMap end -fun sameType (T.TyVar (span1, tv), T.TyVar (span2, tv')) = tv = tv' - | sameType (T.RecordType (span1, fields), T.RecordType (span2, fields')) = Syntax.LabelMap.numItems fields = Syntax.LabelMap.numItems fields' - andalso Syntax.LabelMap.alli (fn (label, ty) => case Syntax.LabelMap.find (fields', label) of - SOME ty' => sameType (ty, ty') - | NONE => false - ) fields - | sameType (T.TyCon (span1, tyargs, tycon), T.TyCon (span2, tyargs', tycon')) = T.eqTyName (tycon, tycon') andalso (ListPair.allEq sameType (tyargs, tyargs') handle ListPair.UnequalLengths => false) - | sameType (T.FnType (span1, ty1, ty2), T.FnType (span2, ty1', ty2')) = sameType (ty1, ty1') andalso sameType (ty2, ty2') +fun sameType (T.TyVar (_, tv), T.TyVar (_, tv')) = tv = tv' + | sameType (T.RecordType (_, fields), T.RecordType (_, fields')) = Syntax.LabelMap.numItems fields = Syntax.LabelMap.numItems fields' + andalso Syntax.LabelMap.alli (fn (label, ty) => case Syntax.LabelMap.find (fields', label) of + SOME ty' => sameType (ty, ty') + | NONE => false + ) fields + | sameType (T.TyCon (_, tyargs, tycon), T.TyCon (_, tyargs', tycon')) = T.eqTyName (tycon, tycon') andalso (ListPair.allEq sameType (tyargs, tyargs') handle ListPair.UnequalLengths => false) + | sameType (T.FnType (_, ty1, ty2), T.FnType (_, ty1', ty2')) = sameType (ty1, ty1') andalso sameType (ty2, ty2') | sameType (_, _) = false fun sameTypeScheme (ctx, span, T.TypeScheme (tyvarsE, tyE), T.TypeScheme (tyvarsA, tyA)) @@ -3311,7 +3309,7 @@ and matchSignature (ctx, env, span, expected : T.Signature, longstrid : T.LongSt in (decs, Syntax.StrIdMap.insert (strMap, strid, T.MkLongStrId (strid', []))) end ) ([], Syntax.StrIdMap.empty) strMap - val (decs, valMap) = Syntax.VIdMap.foldli (fn (vid, (tysc, decs, longvid, ids), (decs', valMap)) => + val (decs, valMap) = Syntax.VIdMap.foldli (fn (vid, (_, decs, longvid, ids), (decs', valMap)) => let val decs = List.foldr (fn (dec, decs) => T.CoreDec (span, dec) :: decs) decs' decs in (decs, Syntax.VIdMap.insert(valMap, vid, (longvid, ids))) end @@ -3327,7 +3325,7 @@ and matchSignature (ctx, env, span, expected : T.Signature, longstrid : T.LongSt T.LetInStrExp (span, decs, strexp) ) end -and matchTyDesc (ctx, env, span, expected : T.TypeStructure, actual : T.TypeStructure) : T.TypeStructure +and matchTyDesc (ctx, _, span, expected : T.TypeStructure, actual : T.TypeStructure) : T.TypeStructure = let val { typeFunction = T.TypeFunction (tyvarsE, tyE), valEnv = valEnvE } = expected val numE = Syntax.VIdMap.numItems valEnvE val { typeFunction = T.TypeFunction (tyvarsA, tyA), valEnv = valEnvA } = actual @@ -3372,8 +3370,8 @@ and matchValDesc (ctx, env, span, expected : T.TypeScheme, longvid : T.LongVId, | T.MkLongVId (_, _, vid) => vid ) val tyargsA = List.map (fn (ty, c) => (T.forceTy ty, c)) tyargsA - val trivial = ListPair.allEq (fn ((tvE, []), (T.TyVar (span2, tvA), [])) => T.eqUTyVar (tvE, tvA) - | ((tvE, [T.IsEqType]), (T.TyVar (span2, tvA), [T.IsEqType])) => T.eqUTyVar (tvE, tvA) + val trivial = ListPair.allEq (fn ((tvE, []), (T.TyVar (_, tvA), [])) => T.eqUTyVar (tvE, tvA) + | ((tvE, [T.IsEqType]), (T.TyVar (_, tvA), [T.IsEqType])) => T.eqUTyVar (tvE, tvA) | _ => false ) (tyvarsE, tyargsA) in if trivial then @@ -3441,21 +3439,21 @@ fun typeCheckStrExp (ctx : Context, env : Env, S.StructExp (span, decs)) : T.Pac , boundTyVars = #boundTyVars env } val strid = newStrId(ctx, Syntax.MkStrId "tmp") - val (s, strexp') = matchQSignature(ctx, env', span, sE, strid, #s sA) + val (_, strexp') = matchQSignature (ctx, env', span, sE, strid, #s sA) val tynames = canonicalOrderForQSignature sE val packageSig = { s = #s sE - , bound = List.map (fn tyname => let val { arity, admitsEquality, longtycon } = T.TyNameMap.lookup (#bound sE, tyname) + , bound = List.map (fn tyname => let val { arity, admitsEquality, longtycon = _ } = T.TyNameMap.lookup (#bound sE, tyname) in { tyname = tyname, arity = arity, admitsEquality = admitsEquality } end ) tynames } - val tyNameMapOutside = T.TyNameMap.foldli (fn (tyname, { arity, admitsEquality, longtycon }, acc) => + val tyNameMapOutside = T.TyNameMap.foldli (fn (tyname, { arity, admitsEquality, longtycon = _ }, acc) => T.TyNameMap.insert (acc, tyname, { arity = arity, admitsEquality = admitsEquality, overloadClass = NONE }) ) T.TyNameMap.empty (#bound sE) val payloadTypes = List.map (fn tyname => let val { longtycon = Syntax.MkQualified (strids, tycon), ... } = T.TyNameMap.lookup (#bound sE, tyname) val { tyConMap, ... } = lookupStr (ctx, #s sA, span, strids) in case Syntax.TyConMap.find (tyConMap, tycon) of - SOME { typeFunction, valEnv } => typeFunction + SOME { typeFunction, valEnv = _ } => typeFunction | NONE => emitFatalError (ctx, [span], "unknown type constructor") end) tynames in (packageSig, tyNameMapOutside, [], T.PackedStrExp { sourceSpan = span @@ -3503,7 +3501,7 @@ fun typeCheckStrExp (ctx : Context, env : Env, S.StructExp (span, decs)) : T.Pac in (tyname, typeFunction, admitsEquality) end ) bound - val instantiation = List.foldl (fn ((tyname, typeFunction, admitsEquality), map) => T.TyNameMap.insert (map, tyname, typeFunction)) T.TyNameMap.empty argumentTypes + val instantiation = List.foldl (fn ((tyname, typeFunction, _), map) => T.TyNameMap.insert (map, tyname, typeFunction)) T.TyNameMap.empty argumentTypes val instantiated = applySubstTyConInSig (ctx, instantiation) paramSig val (_, strexp') = matchSignature (ctx, env', span, instantiated, T.MkLongStrId (strid, []), #s sA) val resultSig = { s = applySubstTyConInSig (ctx, instantiation) (#s resultSig) @@ -3517,17 +3515,17 @@ fun typeCheckStrExp (ctx : Context, env : Env, S.StructExp (span, decs)) : T.Pac , decs @ [T.StrBindDec (span, strid, strexp, sA)] , T.FunctorAppExp { sourceSpan = span , funId = funid - , argumentTypes = List.map (fn (tyname, typeFunction, admitsEquality) => { typeFunction = typeFunction, admitsEquality = admitsEquality }) argumentTypes + , argumentTypes = List.map (fn (_, typeFunction, admitsEquality) => { typeFunction = typeFunction, admitsEquality = admitsEquality }) argumentTypes , argumentStr = strexp' , packageSig = resultSig } ) end ) - | typeCheckStrExp(ctx, env, S.LetInStrExp(span, strdecs, strexp)) = let val (env', strdecs) = typeCheckStrDecs(ctx, env, strdecs) - val (s, tyNameMap, strdecs', strexp) = typeCheckStrExp(ctx, mergeEnv(env, env'), strexp) - in (s, T.TyNameMap.unionWith #2 (#tyNameMap env', tyNameMap), strdecs @ strdecs', strexp) - end + | typeCheckStrExp (ctx, env, S.LetInStrExp (_, strdecs, strexp)) = let val (env', strdecs) = typeCheckStrDecs (ctx, env, strdecs) + val (s, tyNameMap, strdecs', strexp) = typeCheckStrExp(ctx, mergeEnv(env, env'), strexp) + in (s, T.TyNameMap.unionWith #2 (#tyNameMap env', tyNameMap), strdecs @ strdecs', strexp) + end and typeCheckStrDec (ctx : Context, env : Env, S.CoreDec (span, dec)) : Env * TypedSyntax.StrDec list = let val (env', decs) = typeCheckCoreDecs(ctx, env, [dec]) in (env', List.map (fn dec => T.CoreDec (span, dec)) decs) @@ -3551,7 +3549,7 @@ and typeCheckStrDec (ctx : Context, env : Env, S.CoreDec (span, dec)) : Env * Ty strdecs @ [T.StrBindDec (span, strid, strexp, s)] @ strdecs' ) [] binds) end - | typeCheckStrDec(ctx, env, S.LocalStrDec(span, decs1, decs2)) + | typeCheckStrDec (ctx, env, S.LocalStrDec (_, decs1, decs2)) = let val (env', decs1) = typeCheckStrDecs(ctx, env, decs1) val (env'', decs2) = typeCheckStrDecs(ctx, mergeEnv(env, env'), decs2) val env'' = { valMap = #valMap env'' @@ -3564,7 +3562,7 @@ and typeCheckStrDec (ctx : Context, env : Env, S.CoreDec (span, dec)) : Env * Ty } in (env'', decs1 @ decs2) end -and typeCheckStrDecs(ctx : Context, env : Env, []) = (emptyEnv, []) +and typeCheckStrDecs (_ : Context, _ : Env, []) = (emptyEnv, []) | typeCheckStrDecs(ctx, env, dec :: decs) = let val (env', dec) = typeCheckStrDec(ctx, env, dec) val (env'', decs) = typeCheckStrDecs(ctx, mergeEnv(env, env'), decs) in (mergeEnv(env', env''), dec @ decs) @@ -3583,7 +3581,7 @@ fun typeCheckFunExp' (ctx, span, paramEnv, paramSig, strid, strexp) : TypedSynta val resultSig = { s = #s actualSignature , bound = #bound actualSignature @ additionalTyNames } - val payloadTypes = List.map (fn { tyname, arity, admitsEquality } => + val payloadTypes = List.map (fn { tyname, arity, admitsEquality = _ } => let val tyvars = List.tabulate (arity, fn _ => genTyVar (ctx, Syntax.MkTyVar "?")) in T.TypeFunction (tyvars, T.TyCon (span, List.map (fn tv => T.TyVar (span, tv)) tyvars, tyname)) end) (#bound resultSig) @@ -3594,7 +3592,7 @@ fun typeCheckFunExp' (ctx, span, paramEnv, paramSig, strid, strexp) : TypedSynta , paramSig = #s paramSig , resultSig = resultSig } - val funexp = ( List.map (fn tyname => let val { arity, admitsEquality, longtycon } = T.TyNameMap.lookup (#bound paramSig, tyname) + val funexp = ( List.map (fn tyname => let val { arity, admitsEquality, longtycon = _ } = T.TyNameMap.lookup (#bound paramSig, tyname) in { tyname = tyname, arity = arity, admitsEquality = admitsEquality } end ) tynamesInParam @@ -3615,11 +3613,11 @@ fun typeCheckFunExp (ctx, span, env, S.NamedFunExp (strid, sigexp, strexp)) : Ty = let val strid' = newStrId(ctx, strid) val paramSig : T.QSignature = evalSignature (ctx, envToSigEnv env, sigexp) val tyNameMap : TyNameAttr T.TyNameMap.map - = T.TyNameMap.mapi (fn (tyname, { arity, admitsEquality, longtycon }) => - { arity = arity - , admitsEquality = admitsEquality - , overloadClass = NONE - } + = T.TyNameMap.map (fn { arity, admitsEquality, longtycon = _ } => + { arity = arity + , admitsEquality = admitsEquality + , overloadClass = NONE + } ) (#bound paramSig) val paramEnv = { valMap = #valMap env , tyConMap = #tyConMap env @@ -3635,12 +3633,12 @@ fun typeCheckFunExp (ctx, span, env, S.NamedFunExp (strid, sigexp, strexp)) : Ty = let val strid0 = newStrId(ctx, S.MkStrId "param") val paramSig : T.QSignature = evalSignature (ctx, envToSigEnv env, sigexp) val tyNameMap : TyNameAttr T.TyNameMap.map - = T.TyNameMap.mapi (fn (tyname, { arity, admitsEquality, longtycon }) => - { arity = arity - , admitsEquality = admitsEquality - , overloadClass = NONE - } - ) (#bound paramSig) + = T.TyNameMap.map (fn { arity, admitsEquality, longtycon = _ } => + { arity = arity + , admitsEquality = admitsEquality + , overloadClass = NONE + } + ) (#bound paramSig) val paramEnv = { valMap = Syntax.VIdMap.mapi (fn (vid, (tysc, ids)) => (tysc, ids, TypedSyntax.MkLongVId (strid0, [], vid))) (#valMap (#s paramSig)) , tyConMap = #tyConMap (#s paramSig) , tyNameMap = tyNameMap @@ -3685,14 +3683,14 @@ fun typeCheckTopDec(ctx, env, S.StrDec strdec) = let val (env', strdec) = typeCh in (env, binds) end -fun typeCheckTopDecs(ctx, env, []) = (emptyEnv, []) +fun typeCheckTopDecs (_, _, []) = (emptyEnv, []) | typeCheckTopDecs(ctx, env, dec :: decs) = let val (env', dec) = typeCheckTopDec(ctx, env, dec) val (env'', decs) = typeCheckTopDecs(ctx, mergeEnv(env, env'), decs) in (mergeEnv(env', env''), dec @ decs) end (*: val typeCheckProgram : Context * Env * ((Syntax.Dec Syntax.TopDec) list) list -> Env * (TypedSyntax.TopDec list) list *) -fun typeCheckProgram (ctx, env, [] : ((Syntax.Dec Syntax.TopDec) list) list) : Env * (TypedSyntax.TopDec list) list = (emptyEnv, []) +fun typeCheckProgram (_, _, [] : ((Syntax.Dec Syntax.TopDec) list) list) : Env * (TypedSyntax.TopDec list) list = (emptyEnv, []) | typeCheckProgram(ctx, env, topdec :: topdecs) = let val (env', topdec') = typeCheckTopDecs (ctx, env, topdec) val (env'', topdecs') = typeCheckProgram(ctx, mergeEnv(env, env'), topdecs) in (mergeEnv(env', env''), topdec' :: topdecs')