1 (* Copyright (C) 2009-2012,2015,2017 Matthew Fluet.
2 * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor ElaborateCore (S: ELABORATE_CORE_STRUCTS): ELABORATE_CORE =
16 open Control.Elaborate
18 val nonexhaustiveBind = fn () => current nonexhaustiveBind
19 val nonexhaustiveExnBind = fn () => current nonexhaustiveExnBind
20 val nonexhaustiveExnMatch = fn () => current nonexhaustiveExnMatch
21 val nonexhaustiveExnRaise = fn () => current nonexhaustiveExnRaise
22 val nonexhaustiveMatch = fn () => current nonexhaustiveMatch
23 val nonexhaustiveRaise = fn () => current nonexhaustiveRaise
24 val redundantBind = fn () => current redundantBind
25 val redundantMatch = fn () => current redundantMatch
26 val redundantRaise = fn () => current redundantRaise
27 val resolveScope = fn () => current resolveScope
28 val sequenceNonUnit = fn () => current sequenceNonUnit
29 val valrecConstr = fn () => current valrecConstr
30 fun check (c: (bool,bool) t, keyword: string, region) =
39 str (concat (if expert c
40 then [keyword, " disallowed"]
41 else [keyword, " disallowed, compile with -default-ann '",
46 structure ElabControl = Control.Elaborate
58 fun approximateN (l: Layout.t, prefixMax, suffixMax): Layout.t =
60 val s = Layout.toString l
68 else concat [String.prefix (s, prefixMax - 5), " ..."]
70 if n <= prefixMax + suffixMax
72 else concat [String.prefix (s, prefixMax - 2),
74 String.suffix (s, suffixMax - 5)])
76 fun approximate (l: Layout.t): Layout.t =
77 approximateN (l, 35, SOME 25)
78 fun approximatePrefix (l: Layout.t): Layout.t =
79 approximateN (l, 15, NONE)
84 structure Aconst = Const
87 structure Amatch = Match
89 structure Atype = Type
92 structure DatatypeRhs = DatatypeRhs
93 structure DatBind = DatBind
94 structure EbRhs = EbRhs
95 structure Fixop = Fixop
96 structure Longtycon = Longtycon
97 structure Longvid = Longvid
98 structure PrimKind = PrimKind
99 structure ImportExportAttribute = PrimKind.ImportExportAttribute
100 structure SymbolAttribute = PrimKind.SymbolAttribute
101 structure Priority = Priority
102 structure Record = Record
103 structure SortedRecord = SortedRecord
104 structure Symbol = Symbol
105 structure TypBind = TypBind
111 structure Kind = Kind
112 structure TypeEnv = TypeEnv
113 structure TypeStr = TypeStr
114 structure TyvarEnv = TyvarEnv
121 structure Scheme = Scheme
122 structure Time = Time
123 structure Type = Type
129 structure CFunction = CFunction
130 structure CType = CType
131 structure CharSize = CharSize
132 structure Convention = CFunction.Convention
133 structure SymbolScope = CFunction.SymbolScope
134 structure CKind = CFunction.Kind
136 structure Const = Const
137 structure ConstType = Const.ConstType
141 structure IntSize = IntSize
142 structure Lambda = Lambda
144 structure Prim = Prim
145 structure RealSize = RealSize
146 structure RealX = RealX
147 structure SourceInfo = SourceInfo
148 structure Tycon = Tycon
149 structure Tyvar = Tyvar
151 structure WordSize = WordSize
152 structure WordX = WordX
153 structure WordXVector = WordXVector
158 open TypeEnv.TyconExt
163 open TypeEnv.TyvarExt
166 fun matchDiagsFromNoMatch noMatch =
169 {nonexhaustiveExn = Control.Elaborate.DiagDI.Default,
170 nonexhaustive = Control.Elaborate.DiagEIW.Ignore,
171 redundant = Control.Elaborate.DiagEIW.Ignore}
173 {nonexhaustiveExn = nonexhaustiveExnRaise (),
174 nonexhaustive = nonexhaustiveRaise (),
175 redundant = redundantRaise ()}
177 {nonexhaustiveExn = nonexhaustiveExnBind (),
178 nonexhaustive = nonexhaustiveBind (),
179 redundant = redundantBind ()}
181 {nonexhaustiveExn = nonexhaustiveExnMatch (),
182 nonexhaustive = nonexhaustiveMatch (),
183 redundant = redundantMatch ()}
185 structure AdmitsEquality = Tycon.AdmitsEquality
190 structure Field = Field
193 structure Parse = PrecedenceParse (structure Ast = Ast
196 structure Scope = Scope (structure Ast = Ast)
202 fun getName (p: t): string option =
204 Var {name, ...} => SOME (Longvid.toString name)
205 | Constraint (p, _) => getName p
207 if 1 = Vector.length v
208 then getName (Vector.first v)
210 | Layered {var, ...} => SOME (Avar.toString var)
214 Trace.trace ("ElaborateCore.Apat.getName", layout, Option.layout String.layout)
218 fun elaborateType (ty: Atype.t, E: Env.t,
219 {bogusAsUnknown: bool}): Type.t =
221 fun makeBogus (mc, ts) =
225 val arity = Vector.length ts
228 (mc, ("t", NONE), fn (c, _) =>
229 (Longtycon.toString c,
230 SOME (Longtycon.region c)))
234 kind = Kind.Arity arity,
239 fun loop (ty: Atype.t): Type.t =
240 case Atype.node ty of
241 Atype.Var a => (* rule 44 *)
242 (case TyvarEnv.lookupTyvar a of
243 NONE => makeBogus (NONE, Vector.new0 ())
244 | SOME a => Type.var a)
245 | Atype.Con (c, ts) => (* rules 46, 47 *)
247 val ts = Vector.map (ts, loop)
249 case Env.lookupLongtycon (E, c) of
250 NONE => makeBogus (SOME c, ts)
253 val kind = TypeStr.kind s
254 val numArgs = Vector.length ts
269 (List.tabulate (n, fn _ => str "_"),
273 Ast.Longtycon.layout c]
277 seq [str "type constructor applied to incorrect number of type arguments: ",
278 Ast.Longtycon.layout c],
279 align [seq [str "expects: ", doit n],
280 seq [str "but got: ", doit numArgs],
281 seq [str "in: ", Atype.layout ty]])
284 case Int.compare (n, numArgs) of
286 (error (); Vector.prefix (ts, n))
293 (n - numArgs, fn _ =>
295 (NONE, Vector.new0 ()))])
299 TypeStr.apply (s, ts)
302 case (Ast.Longtycon.split c, Vector.length ts) of
304 if Ast.Tycon.equals (c, Ast.Tycon.arrow)
305 then Type.arrow (Vector.sub (ts, 0),
310 | Atype.Paren t => loop t
311 | Atype.Record r => (* rules 45, 49 *)
313 (SortedRecord.fromVector
316 fn (f, (_, t)) => (f, loop t))))
321 val overloadChecks: (Ast.Priority.t * (unit -> unit)) list ref = ref []
323 fun resolveOverloads () =
324 (* List.insertionSort is anti-stable; hence, it sorts and reverses the overloads. *)
325 (List.foreach (List.insertionSort
326 (!overloadChecks, fn ((p1,_),(p2,_)) =>
327 Priority.<= (p2, p1)),
329 ; overloadChecks := [])
331 val unresolvedFlexRecordChecks: (unit -> unit) list ref = ref []
333 fun reportUnresolvedFlexRecords () =
334 (List.foreach (rev (!unresolvedFlexRecordChecks), fn th => th ())
335 ; unresolvedFlexRecordChecks := [])
337 val undeterminedTypeChecks: (unit -> unit) list ref = ref []
339 fun reportUndeterminedTypes () =
340 (List.foreach (rev (!undeterminedTypeChecks), fn th => th ())
341 ; undeterminedTypeChecks := [])
343 val sequenceNonUnitChecks: (unit -> unit) list ref = ref []
345 fun reportSequenceNonUnit () =
346 (List.foreach (rev (!sequenceNonUnitChecks), fn th => th ())
347 ; sequenceNonUnitChecks := [])
349 val {hom = typeTycon: Type.t -> Tycon.t option, ...} =
350 Type.makeHom {con = fn (c, _) => SOME c,
351 expandOpaque = false,
356 ("ElaborateCore.typeTycon", Type.layout, Option.layout Tycon.layout)
359 fun 'a elabConst (c: Aconst.t,
360 {layoutPrettyType: Type.t -> Layout.t},
361 make: (unit -> Const.t) * Type.t -> 'a,
362 {false = f: 'a, true = t: 'a}): 'a =
364 fun error (kind: string, ty: Type.t): unit =
367 seq [str kind, str " too large for type: ", Aconst.layout c],
368 seq [str "type: ", layoutPrettyType ty])
369 fun choose (tycon, all, sizeTycon, make) =
370 case List.peek (all, fn s => Tycon.equals (tycon, sizeTycon s)) of
371 NONE => Const.string "<bogus>"
373 fun delay (ty: unit -> Type.t, resolve: Type.t -> Const.t): 'a =
376 val resolve = Promise.lazy (fn () => resolve ty)
377 val _ = List.push (overloadChecks, (Priority.default, ignore o resolve))
387 case Aconst.node c of
388 Aconst.Bool b => if b then t else f
391 (Type.unresolvedChar, fn ty =>
392 choose (typeTycon ty,
394 Tycon.word o WordSize.fromBits o CharSize.bits,
397 val ws = WordSize.fromBits (CharSize.bits cs)
400 (if CharSize.isInRange (cs, ch)
401 then WordX.fromIntInf (ch, ws)
402 else (error ("char constant", ty); WordX.zero ws))
406 (Type.unresolvedInt, fn ty =>
408 val tycon = typeTycon ty
410 if Tycon.equals (tycon, Tycon.intInf)
413 choose (tycon, WordSize.all, Tycon.word, fn s =>
415 (if WordSize.isInRange (s, i, {signed = true})
416 then WordX.fromIntInf (i, s)
417 else (error ("int constant", ty); WordX.zero s)))
421 (Type.unresolvedReal, fn ty =>
422 choose (typeTycon ty, RealSize.all, Tycon.real, fn s =>
423 Const.Real (case RealX.make (r, s) of
424 NONE => (error ("real constant", ty); RealX.zero s)
428 (Type.unresolvedString, fn ty =>
429 choose (typeTycon (Type.deVector ty),
431 Tycon.word o WordSize.fromBits o CharSize.bits,
434 val ws = WordSize.fromBits (CharSize.bits cs)
438 (WordXVector.tabulate
439 ({elementSize = ws}, Vector.length v, fn i =>
441 val ch = Vector.sub (v, i)
443 if CharSize.isInRange (cs, ch)
444 then WordX.fromIntInf (ch, ws)
445 else (List.push (bigs, ch)
449 if List.isEmpty (!bigs)
453 seq [str "string constant with ",
456 | _ => "characters "),
457 str "too large for type: ",
461 Aconst.layout (Aconst.makeRegion (Aconst.Char ch, Region.bogus))),
463 seq [str "type: ", layoutPrettyType ty])
469 (Type.unresolvedWord, fn ty =>
470 choose (typeTycon ty, WordSize.all, Tycon.word, fn s =>
472 (if WordSize.isInRange (s, w, {signed = false})
473 then WordX.fromIntInf (w, s)
474 else (error ("word constant", ty); WordX.zero s))))
478 fun unifySeq (seqTy, seqStr,
479 trs: (Type.t * Region.t) vector,
481 if Vector.isEmpty trs
482 then seqTy (Type.new ())
485 val (t, _) = Vector.first trs
489 unify (t, t', fn (l, l') =>
491 str (seqStr ^ " with element of different type"),
492 align [seq [str "element: ", l'],
493 seq [str "previous: ", l]])))
498 fun unifyList (trs: (Type.t * Region.t) vector, unify): Type.t =
499 unifySeq (Type.list, "list", trs, unify)
500 fun unifyVector (trs: (Type.t * Region.t) vector, unify): Type.t =
501 unifySeq (Type.vector, "vector", trs, unify)
504 val elabPatInfo = Trace.info "ElaborateCore.elabPat"
510 val fromAst = newString o Avar.toString
513 structure DiagUtils =
515 type t = {layoutPrettyType: Type.t -> LayoutPretty.t,
516 layoutPrettyTycon: Tycon.t -> Layout.t,
517 layoutPrettyTyvar: Tyvar.t -> Layout.t,
518 unify: Type.t * Type.t * (Layout.t * Layout.t -> Region.t * Layout.t * Layout.t) -> unit}
521 val {layoutPrettyTycon, ...} =
522 Env.makeLayoutPrettyTycon (E, {prefixUnset = true})
523 val {layoutPretty = layoutPrettyTyvar, ...} =
524 TyvarEnv.makeLayoutPretty ()
525 val layoutPrettyType = fn t =>
527 (t, {expandOpaque = false,
528 layoutPrettyTycon = layoutPrettyTycon,
529 layoutPrettyTyvar = layoutPrettyTyvar})
530 fun unify (t, t', error) =
532 val error = fn (l, l', {notes}) =>
534 val (r, m, d) = error (l, l')
537 (r, m, align [d, notes ()])
541 (t, t', {error = error,
542 layoutPretty = layoutPrettyType,
543 layoutPrettyTycon = layoutPrettyTycon,
544 layoutPrettyTyvar = layoutPrettyTyvar})
547 {layoutPrettyType = layoutPrettyType,
548 layoutPrettyTycon = layoutPrettyTycon,
549 layoutPrettyTyvar = layoutPrettyTyvar,
556 -> Apat.t * Env.t * {bind: bool, isRvb: bool}
557 -> Cpat.t * (Avar.t * Var.t * Type.t) vector =
560 val others: (Apat.t * (Avar.t * Var.t * Type.t) vector) list ref = ref []
562 fn (p: Apat.t, E: Env.t, {bind = bindInEnv, isRvb}) =>
564 val {layoutPrettyType, unify, ...} = DiagUtils.make E
566 seq [str "in: ", approximate (Apat.layout p)]
569 val renames: (Avar.t * Var.t) list ref = ref []
572 case List.peek (!renames, fn (y, _) => Avar.equals (x, y)) of
573 NONE => let val x' = Var.fromAst x
574 in (List.push (renames, (x, x')); x')
578 val xts: (Avar.t * Var.t * Type.t) list ref = ref []
579 fun bindToType (x: Avar.t, t: Type.t): Var.t =
582 Avid.checkRedefineSpecial
586 keyword = if isRvb then "val rec" else "pattern"})
589 case List.peek (!xts, fn (y, _, _) => Avar.equals (x, y)) of
594 seq [str "duplicate variable in pattern: ", Avar.layout x],
596 val _ = List.push (xts, (x, x', t))
600 fun bind (x: Avar.t): Var.t * Type.t =
604 (bindToType (x, t), t)
606 fun elabType (t: Atype.t): Type.t =
607 elaborateType (t, E, {bogusAsUnknown = true})
608 fun loop (arg: Apat.t) =
609 Trace.traceInfo' (elabPatInfo, Apat.layout, Cpat.layout)
612 val region = Apat.region p
614 seq [str "in: ", approximate (Apat.layout p)]
615 val unify = fn (a, b, f) =>
620 (r, m, align [d, ctxt ()])
622 fun unifyPatternConstraint (p, c) =
624 (p, c, fn (l1, l2) =>
626 str "pattern and constraint disagree",
627 align [seq [str "pattern: ", l1],
628 seq [str "constraint: ", l2]]))
630 Cpat.wild (Type.new ())
634 (case Env.lookupLongcon (E, c) of
638 val {args, instance} = Scheme.instantiate s
641 val (argType, resultType) =
642 case Type.deArrowOpt instance of
647 (Type.new (), Type.new ())
650 (instance, Type.arrow types,
653 str "constant constructor applied to argument in pattern",
660 (Cpat.ty p, argType, fn (l, l') =>
662 str "constructor applied to incorrect argument in pattern",
663 align [seq [str "expects: ", l'],
664 seq [str "but got: ", l]]))
666 Cpat.make (Cpat.Con {arg = SOME p,
674 {layoutPrettyType = #1 o layoutPrettyType},
675 fn (resolve, ty) => Cpat.make (Cpat.Const resolve, ty),
676 {false = Cpat.falsee,
678 | Apat.Constraint (p, t) =>
682 unifyPatternConstraint
683 (Cpat.ty p', elabType t)
687 | Apat.FlatApp items =>
689 (items, E, fn () => ctxt ()))
690 | Apat.Layered {var = x, constraint, pat, ...} =>
695 | SOME t => elabType t
696 val xc = Avid.toCon (Avid.fromVar x)
698 case Env.peekLongcon (E, Ast.Longcon.short xc) of
699 NONE => bindToType (x, t)
705 seq [str "constructor cannot be redefined by as: ",
713 unifyPatternConstraint (Cpat.ty pat', t)
715 Cpat.make (Cpat.Layered (x, pat'), t)
719 val ps' = Vector.map (ps, loop)
721 Cpat.make (Cpat.List ps',
723 (Vector.map2 (ps, ps', fn (p, p') =>
724 (Cpat.ty p', Apat.region p)),
729 val _ = check (Control.Elaborate.allowOrPats, "Or patterns", region)
731 val n = Vector.length ps
741 val ps' = Vector.map (ps, fn (_, p', _) => p')
745 (ps, [], fn ((p, _, xtsPat), xtsPats) =>
747 (xtsPat, xtsPats, fn ((x, x', t), xtsPats) =>
748 case List.peek (xtsPats, fn (y, _, _, _) => Avar.equals (x, y)) of
749 NONE => (x, x', t, ref [x])::xtsPats
750 | SOME (_, _, t', l) =>
752 val _ = List.push (l, x)
755 (t', t, fn (l', l) =>
757 seq [str "or-pattern with variable of different type: ",
759 align [seq [str "variable: ", l],
760 seq [str "previous: ", l'],
761 seq [str "in: ", approximate (Apat.layout p)]]))
767 (xtsPats, fn (x, _, _, l) =>
768 if List.length (!l) <> n
773 seq [str "variable does not occur in all patterns of or-pattern: ",
783 (ps, fn (p, p', _) =>
785 (t, Cpat.ty p', fn (l, l') =>
787 str "or-pattern with pattern of different type",
788 align [seq [str "pattern: ", l'],
789 seq [str "previous: ", l],
790 seq [str "in: ", approximate (Apat.layout p)]])))
793 (xtsPats, xtsOrig, fn ((x, x', t, l), xtsMerge) =>
794 case List.peek (xtsMerge, fn (y, _, _) => Avar.equals (x, y)) of
795 NONE => (x, x', t)::xtsMerge
800 (List.rev (!l), fn x =>
803 seq [str "duplicate variable in pattern: ", Avar.layout x],
808 val _ = xts := xtsMerge
810 Cpat.make (Cpat.Or ps', t)
812 | Apat.Paren p => loop p
813 | Apat.Record {flexible, items} =>
814 (* rules 36, 38, 39 and Appendix A, p.57 *)
823 Apat.Item.Field p => p
824 | Apat.Item.Vid (vid, tyo, po) =>
829 Apat.longvid (Longvid.short vid)
833 var = Ast.Vid.toVar vid,
839 | SOME ty => Apat.constraint (p, ty)
841 val ps = Vector.map (ps, loop)
842 val r = SortedRecord.zip (fs, Vector.map (ps, Cpat.ty))
847 val (t, isResolved) = Type.flexRecord r
854 str "unresolved ... in record pattern",
856 val _ = List.push (unresolvedFlexRecordChecks, resolve)
864 (Cpat.Record (Record.fromVector (Vector.zip (fs, ps))),
868 Cpat.tuple (Vector.map (ps, loop))
869 | Apat.Var {name, ...} =>
871 val (strids, x) = Ast.Longvid.split name
874 val (x, t) = bind (Ast.Vid.toVar x)
876 Cpat.make (Cpat.Var x, t)
879 case Env.peekLongcon (E, Ast.Longvid.toLongcon name) of
881 if List.isEmpty strids
888 seq [str "undefined constructor: ",
889 Ast.Longvid.layout name],
892 Cpat.make (Cpat.Wild, Type.new ())
895 if List.isEmpty strids andalso isRvb
898 val {args, instance} =
901 if Type.isArrow instance
905 seq [str "constructor used without argument in pattern: ",
906 Ast.Longvid.layout name],
911 (Cpat.Con {arg = NONE,
919 val _ = check (ElabControl.allowVectorPats, "Vector patterns", Apat.region p)
920 val ps' = Vector.map (ps, loop)
922 Cpat.make (Cpat.Vector ps',
924 (Vector.map2 (ps, ps', fn (p, p') =>
925 (Cpat.ty p', Apat.region p)),
929 Cpat.make (Cpat.Wild, Type.new ())
932 val xts = Vector.fromList (!xts)
935 (xts, fn (x, _, _) =>
937 (!others, fn (p, v) =>
938 if Vector.exists (v, fn (y, _, _) =>
946 seq [str "variable bound in multiple patterns: ",
948 align [seq [str "pattern: ",
949 approximate (Apat.layout p)],
950 seq [str "previous: ",
951 approximate (Apat.layout p')]]))
952 val _ = List.push (others, (p, xts))
956 (xts, fn (x, x', t) =>
957 Env.extendVar (E, x, x', Scheme.fromType t,
965 (*---------------------------------------------------*)
967 (*---------------------------------------------------*)
973 val layout = List.layout String.layout
976 val elabDecInfo = Trace.info "ElaborateCore.elabDec"
977 val elabExpInfo = Trace.info "ElaborateCore.elabExp"
983 val nullary: (string * CType.t * Tycon.t) list =
985 fun sized (tycon: Bits.t -> Tycon.t, ctypes) =
989 val c = tycon (Bytes.toBits (CType.size cty))
990 val s = Tycon.toString c
993 (String.size s, fn i =>
995 val c = String.sub (s, i)
997 if i = 0 then Char.toUpper c else c
1003 [("Bool", CType.bool, Tycon.bool),
1004 ("CPointer", CType.cpointer, Tycon.cpointer),
1005 ("Real32", CType.real RealSize.R32, Tycon.real RealSize.R32),
1006 ("Real64", CType.real RealSize.R64, Tycon.real RealSize.R64),
1007 ("Thread", CType.thread, Tycon.thread)]
1008 @ sized (Tycon.char o CharSize.fromBits,
1012 [Word8, Word16, Word32]
1014 @ sized (Tycon.int o IntSize.fromBits,
1018 [Int8, Int16, Int32, Int64]
1020 @ sized (Tycon.word o WordSize.fromBits,
1024 [Word8, Word16, Word32, Word64]
1029 List.map (nullary, fn (name, ctype, tycon) =>
1030 {ctype = ctype, name = name, tycon = tycon})
1032 val unary: Tycon.t list =
1033 [Tycon.array, Tycon.reff, Tycon.vector]
1035 fun toNullaryCType (t: t): {ctype: CType.t, name: string} option =
1040 (List.peek (nullary, fn {tycon = c', ...} =>
1041 Tycon.equals (c, c')),
1042 fn {ctype, name, ...} => {ctype = ctype, name = name})
1044 and toUnaryCType (t: t): {ctype: CType.t, name: string} option =
1048 if List.exists (unary, fn c' => Tycon.equals (c, c'))
1049 andalso 1 = Vector.length ts
1050 andalso isSome (toCType (Vector.first ts))
1051 then SOME {ctype = CType.objptr, name = "Objptr"}
1054 and toCType (ty: t): {ctype: CType.t, name: string} option =
1055 case toNullaryCType ty of
1056 NONE => toUnaryCType ty
1057 | SOME {ctype, name} => SOME {ctype = ctype, name = name}
1061 ("ElaborateCore.Type.toCType",
1063 Option.layout (fn {ctype, name} =>
1065 [("ctype", CType.layout ctype),
1066 ("name", String.layout name)]))
1069 type z = {ctype: CType.t, name: string, ty: t}
1071 fun toCBaseType (ty: t): z option =
1074 | SOME {ctype, name} =>
1075 SOME {ctype = ctype, name = name, ty = ty}
1076 fun toCArgType (ty: t): z vector option =
1077 case deTupleOpt ty of
1079 (case toCBaseType ty of
1081 | SOME z => SOME (Vector.new1 z))
1087 case toCBaseType ty of
1090 fun toCRetType (ty: t): z option option =
1091 case toCBaseType ty of
1092 NONE => if Type.isUnit ty
1095 | SOME z => SOME (SOME z)
1096 fun toCFunType (ty: t): (z vector * z option) option =
1097 case deArrowOpt ty of
1099 | SOME (arg, ret) =>
1100 (case toCArgType arg of
1103 (case toCRetType ret of
1105 | SOME ret => SOME (arg, ret)))
1106 fun toCPtrType (ty: t): z option =
1107 if Type.isCPointer ty
1108 then let val {ctype, name} = valOf (toCType ty)
1109 in SOME {ctype = ctype, name = name, ty = ty}
1114 val isIEAttributeConvention =
1115 fn ImportExportAttribute.Cdecl => true
1116 | ImportExportAttribute.Stdcall => true
1119 fun parseIEAttributesConvention (attributes: ImportExportAttribute.t list)
1120 : Convention.t option =
1122 [] => SOME Convention.Cdecl
1125 ImportExportAttribute.Cdecl => SOME Convention.Cdecl
1126 | ImportExportAttribute.Stdcall =>
1131 Target.Cygwin => true
1132 | Target.MinGW => true
1135 then SOME Convention.Stdcall
1136 else SOME Convention.Cdecl
1140 val isIEAttributeKind =
1141 fn ImportExportAttribute.Impure => true
1142 | ImportExportAttribute.Pure => true
1143 | ImportExportAttribute.Runtime => true
1144 | ImportExportAttribute.Reentrant => true
1147 fun parseIEAttributesKind (attributes: ImportExportAttribute.t list)
1150 [] => SOME CKind.Impure
1153 ImportExportAttribute.Impure => SOME CKind.impure
1154 | ImportExportAttribute.Pure => SOME CKind.pure
1155 | ImportExportAttribute.Runtime => SOME CKind.runtimeDefault
1156 | ImportExportAttribute.Reentrant => SOME CKind.reentrant
1160 val isIEAttributeSymbolScope =
1161 fn ImportExportAttribute.External => true
1162 | ImportExportAttribute.Private => true
1163 | ImportExportAttribute.Public => true
1166 fun parseIEAttributesSymbolScope (attributes: ImportExportAttribute.t list,
1167 defScope : SymbolScope.t)
1168 : SymbolScope.t option =
1172 ImportExportAttribute.External => SOME SymbolScope.External
1173 | ImportExportAttribute.Private => SOME SymbolScope.Private
1174 | ImportExportAttribute.Public => SOME SymbolScope.Public
1178 fun scopeCheck {name, symbolScope, region} =
1181 Control.warning (region, seq (List.map (l, str)), empty)
1183 Ffi.checkScope {name = name, symbolScope = symbolScope}
1185 if symbolScope = oldScope then () else
1186 warn [ "symbol '", name, "' redeclared as ",
1187 SymbolScope.toString symbolScope,
1189 SymbolScope.toString oldScope,
1190 "). This may cause linker errors"]
1193 fun import {attributes: ImportExportAttribute.t list,
1196 name: string option,
1198 layoutPrettyType: Type.t -> Layout.t}: Type.t Prim.t =
1200 fun error l = Control.error (region, l, empty)
1201 fun invalidAttributes () =
1202 error (seq [str "invalid attributes for _import: ",
1203 List.layout ImportExportAttribute.layout attributes])
1204 fun invalidType () =
1207 str "invalid type for _import",
1208 layoutPrettyType elabedTy)
1210 case Type.toCFunType expandedTy of
1213 val () = invalidType ()
1217 | SOME (args, result) =>
1219 datatype z = datatype CFunction.Target.t
1221 List.keepAll (attributes, isIEAttributeConvention)
1223 case parseIEAttributesConvention convention of
1224 NONE => (invalidAttributes ()
1228 List.keepAll (attributes, isIEAttributeKind)
1230 case parseIEAttributesKind kind of
1231 NONE => (invalidAttributes ()
1235 List.keepAll (attributes, isIEAttributeSymbolScope)
1239 (if List.isEmpty symbolScope
1241 else invalidAttributes ()
1242 ; SymbolScope.External)
1246 case parseIEAttributesSymbolScope
1247 (symbolScope, SymbolScope.External) of
1248 NONE => (invalidAttributes ()
1249 ; SymbolScope.External)
1251 val () = scopeCheck {name = name,
1252 symbolScope = symbolScope,
1257 val addrTy = Type.cpointer
1259 CFunction.T {args = let
1260 val args = Vector.map (args, #ty)
1265 [Vector.new1 addrTy, args]
1267 convention = convention,
1269 prototype = (Vector.map (args, #ctype),
1270 Option.map (result, #ctype)),
1271 return = (case result of
1273 | SOME {ty, ...} => ty),
1274 symbolScope = symbolScope,
1275 target = (case name of
1277 | SOME name => Direct name)}
1283 fun primApp {args, prim, result: Type.t} =
1285 val targs = Prim.extractTargs (prim,
1286 {args = Vector.map (args, Cexp.ty),
1288 typeOps = {deArray = Type.deArray,
1289 deArrow = Type.deArrow,
1291 deVector = Type.deVector,
1292 deWeak = Type.deWeak}})
1294 Cexp.make (Cexp.PrimApp {args = args,
1302 Cexp.make (Cexp.Const
1303 (fn () => Const.word (WordX.zero WordSize.bool)),
1304 Type.word WordSize.bool)
1306 Cexp.make (Cexp.Const
1307 (fn () => Const.word (WordX.one WordSize.bool)),
1308 Type.word WordSize.bool)
1309 fun zeroExpPtrdiff () =
1310 Cexp.make (Cexp.Const
1311 (fn () => Const.word (WordX.zero (WordSize.cptrdiff ()))),
1312 Type.word (WordSize.cptrdiff ()))
1314 fun mkAddress {expandedPtrTy: Type.t,
1316 cty: CType.t option,
1317 symbolScope: SymbolScope.t }: Cexp.t =
1318 primApp {args = Vector.new0 (),
1319 prim = Prim.ffiSymbol {name = name,
1321 symbolScope = symbolScope},
1322 result = expandedPtrTy}
1324 fun mkFetch {ctypeCbTy, isBool,
1326 ptrExp: Cexp.t}: Cexp.t =
1329 primApp {args = Vector.new2 (ptrExp, zeroExpPtrdiff ()),
1330 prim = Prim.cpointerGet ctypeCbTy,
1332 then Type.word WordSize.bool
1335 if not isBool then fetchExp else
1337 {args = Vector.new2 (fetchExp, zeroExpBool),
1338 prim = Prim.wordEqual WordSize.bool,
1339 result = expandedCbTy},
1344 fun mkStore {ctypeCbTy, isBool,
1345 ptrExp: Cexp.t, valueExp: Cexp.t}: Cexp.t =
1348 if not isBool then valueExp else
1349 Cexp.iff (valueExp, oneExpBool, zeroExpBool)
1351 primApp {args = Vector.new3 (ptrExp, zeroExpPtrdiff (), valueExp),
1352 prim = Prim.cpointerSet ctypeCbTy,
1356 fun mkSymbol {ctypeCbTy: CType.t,
1357 expandedCbTy: Type.t,
1358 ptrExp: Cexp.t}: Cexp.t =
1360 val isBool = Type.isBool expandedCbTy
1361 val getArg = Var.newNoname ()
1362 val setArg = Var.newNoname ()
1364 (Cexp.tuple o Vector.new2)
1365 ((Cexp.lambda o Lambda.make)
1367 argType = Type.unit,
1368 body = mkFetch {ctypeCbTy = ctypeCbTy,
1370 expandedCbTy = expandedCbTy,
1373 (Cexp.lambda o Lambda.make)
1375 argType = expandedCbTy,
1376 body = mkStore {ctypeCbTy = ctypeCbTy,
1379 valueExp = Cexp.var (setArg, expandedCbTy)},
1383 val isSymbolAttributeAlloc =
1384 fn SymbolAttribute.Alloc => true
1387 fun parseSymbolAttributesAlloc (attributes: SymbolAttribute.t list)
1392 SymbolAttribute.Alloc => SOME true
1396 val isSymbolAttributeSymbolScope =
1397 fn SymbolAttribute.Private => true
1398 | SymbolAttribute.Public => true
1399 | SymbolAttribute.External => true
1402 fun parseSymbolAttributesSymbolScope (attributes: SymbolAttribute.t list,
1403 defScope: SymbolScope.t)
1404 : SymbolScope.t option =
1408 SymbolAttribute.Private => SOME SymbolScope.Private
1409 | SymbolAttribute.Public => SOME SymbolScope.Public
1410 | SymbolAttribute.External => SOME SymbolScope.External
1414 fun address {attributes: SymbolAttribute.t list,
1419 layoutPrettyType: Type.t -> Layout.t}: Cexp.t =
1421 fun error l = Control.error (region, l, empty)
1422 fun invalidAttributes () =
1423 error (seq [str "invalid attributes for _address: ",
1424 List.layout SymbolAttribute.layout attributes])
1425 fun invalidType () =
1427 (region, str "invalid type for _address",
1428 layoutPrettyType elabedTy)
1430 case Type.toCPtrType expandedTy of
1431 NONE => (invalidType (); ())
1433 val expandedPtrTy = expandedTy
1435 case List.keepAll (attributes, isSymbolAttributeAlloc) of
1437 | _ => invalidAttributes ()
1439 List.keepAll (attributes, isSymbolAttributeSymbolScope)
1441 case parseSymbolAttributesSymbolScope
1442 (symbolScope, SymbolScope.External) of
1443 NONE => (invalidAttributes ()
1444 ; SymbolScope.External)
1446 val () = scopeCheck {name = name,
1447 symbolScope = symbolScope,
1450 mkAddress {expandedPtrTy = expandedPtrTy,
1452 symbolScope = symbolScope,
1454 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
1456 wrap (addrExp, elabedTy)
1459 fun symbolDirect {attributes: SymbolAttribute.t list,
1464 layoutPrettyType: Type.t -> Layout.t}: Cexp.t =
1466 fun error l = Control.error (region, l, empty)
1467 fun invalidAttributes () =
1468 error (seq [str "invalid attributes for _symbol: ",
1469 List.layout SymbolAttribute.layout attributes])
1470 fun invalidType () =
1472 (region, str "invalid type for _symbol",
1473 layoutPrettyType elabedTy)
1478 val invalidType = fn () =>
1480 ; ignore (escape Type.word8)
1481 ; Error.bug "ElaborateCore.symbolDirect.escape")
1483 case Type.deTupleOpt expandedTy of
1484 NONE => invalidType ()
1486 if Vector.length tys <> 2
1490 case Type.deArrowOpt ty of
1491 NONE => invalidType ()
1493 val (getArgTy, getResTy) =
1494 doit (Vector.first tys)
1495 val (setArgTy, setResTy) =
1496 doit (Vector.sub (tys, 1))
1498 if Type.isUnit getArgTy
1502 if Type.isUnit setResTy
1506 if Type.canUnify (getResTy, setArgTy)
1514 case Type.toCBaseType expandedCbTy of
1515 NONE => (invalidType ()
1516 ; CType.word (WordSize.word8, {signed = false}))
1517 | SOME {ctype, ...} => ctype
1519 List.keepAll (attributes, isSymbolAttributeAlloc)
1521 case parseSymbolAttributesAlloc alloc of
1522 NONE => (invalidAttributes ()
1526 if alloc then SymbolScope.Public else SymbolScope.External
1528 List.keepAll (attributes, isSymbolAttributeSymbolScope)
1530 case parseSymbolAttributesSymbolScope
1531 (symbolScope, defScope) of
1532 NONE => (invalidAttributes ()
1536 if alloc andalso symbolScope = SymbolScope.External
1537 then invalidAttributes () else ()
1538 val () = scopeCheck {name = name,
1539 symbolScope = symbolScope,
1542 if not alloc then () else
1543 Ffi.addSymbol {name = name,
1545 symbolScope = symbolScope}
1547 mkAddress {expandedPtrTy = Type.cpointer,
1549 cty = SOME ctypeCbTy,
1550 symbolScope = symbolScope}
1552 mkSymbol {ctypeCbTy = ctypeCbTy,
1553 expandedCbTy = expandedCbTy,
1555 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
1557 wrap (symExp, elabedTy)
1560 fun symbolIndirect {elabedTy: Type.t,
1563 layoutPrettyType: Type.t -> Layout.t}: Cexp.t =
1565 fun invalidType () =
1567 (region, str "invalid type for _symbol",
1568 layoutPrettyType elabedTy)
1569 val (expandedPtrTy, expandedCbTy) =
1573 val invalidType = fn () =>
1575 ; ignore (escape (Type.cpointer, Type.word8))
1576 ; Error.bug "ElaborateCore.symbolIndirect.escape")
1578 case Type.deArrowOpt expandedTy of
1579 NONE => invalidType ()
1580 | SOME (ptrTy, symTy) =>
1581 (case Type.deTupleOpt symTy of
1582 NONE => invalidType ()
1584 if Vector.length tys <> 2
1588 case Type.deArrowOpt ty of
1589 NONE => invalidType ()
1591 val (getArgTy, getResTy) =
1592 doit (Vector.sub (tys, 0))
1593 val (setArgTy, setResTy) =
1594 doit (Vector.sub (tys, 1))
1596 if Type.isUnit getArgTy
1600 if Type.isUnit setResTy
1604 if Type.canUnify (getResTy, setArgTy)
1612 case Type.toCBaseType expandedCbTy of
1613 NONE => (invalidType (); CType.word (WordSize.word8, {signed = false}))
1614 | SOME {ctype, ...} => ctype
1616 case Type.toCPtrType expandedPtrTy of
1617 NONE => (invalidType (); ())
1619 val ptrArg = Var.newNoname ()
1620 val ptrExp = Cexp.var (ptrArg, expandedPtrTy)
1622 mkSymbol {ctypeCbTy = ctypeCbTy,
1623 expandedCbTy = expandedCbTy,
1625 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
1627 wrap ((Cexp.lambda o Lambda.make)
1629 argType = expandedPtrTy,
1636 fun export {attributes: ImportExportAttribute.t list,
1641 layoutPrettyType: Type.t -> Layout.t}: Aexp.t =
1643 fun error l = Control.error (region, l, empty)
1644 fun invalidAttributes () =
1645 error (seq [str "invalid attributes for _export: ",
1646 List.layout ImportExportAttribute.layout attributes])
1647 fun invalidType () =
1650 str "invalid type for _export",
1651 layoutPrettyType elabedTy)
1653 List.keepAll (attributes, isIEAttributeConvention)
1655 case parseIEAttributesConvention convention of
1656 NONE => (invalidAttributes ()
1660 List.keepAll (attributes, isIEAttributeSymbolScope)
1662 case parseIEAttributesSymbolScope
1663 (symbolScope, SymbolScope.Public) of
1664 NONE => (invalidAttributes ()
1665 ; SymbolScope.Public)
1666 | SOME SymbolScope.External =>
1667 (invalidAttributes ()
1668 ; SymbolScope.Public)
1670 val () = scopeCheck {name = name,
1671 symbolScope = symbolScope,
1673 val (exportId, args, res) =
1674 case Type.toCFunType expandedTy of
1677 ; (0, Vector.new0 (), NONE))
1678 | SOME (args, result) =>
1681 Ffi.addExport {args = Vector.map (args, #ctype),
1682 convention = convention,
1684 res = Option.map (result, #ctype),
1685 symbolScope = symbolScope}
1690 fun id (name: string) =
1691 Aexp.longvid (Longvid.short
1692 (Vid.fromSymbol (Symbol.fromString name, region)))
1693 fun int (i: int): Aexp.t =
1694 Aexp.const (Aconst.makeRegion (Aconst.Int (IntInf.fromInt i), region))
1695 val f = Var.fromSymbol (Symbol.fromString "f", region)
1696 val p = Var.fromSymbol (Symbol.fromString "p", region)
1713 (args, fn (i, {name, ...}) =>
1717 (Symbol.fromString (concat ["x", Int.toString i]),
1724 (id (concat ["get", name]),
1725 (Exp.tuple o Vector.new2)
1726 (Exp.var p, int (i + 1))))
1730 val resVar = Var.fromSymbol (Symbol.fromString "res", region)
1731 fun newVar () = Var.fromSymbol (Symbol.fromString "none", region)
1738 ((resVar, Exp.app (Exp.var f,
1739 Exp.tuple (Vector.map (args, Exp.var)))),
1742 NONE => Exp.constraint (Exp.var resVar, Type.unit)
1743 | SOME {name, ...} =>
1745 (id (concat ["set", name]),
1746 (Exp.tuple o Vector.new3)
1748 int (Vector.length args + 1),
1749 Exp.var resVar))))),
1750 fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
1751 Exp.tuple (Vector.new0 ()),
1758 ("ElaborateCore.export",
1759 fn {name, ...} => String.layout name,
1768 val x = Avar.fromSymbol (Symbol.fromString "#", Region.bogus)
1769 val xField = Apat.Item.Field (Apat.var x)
1772 fun selector (f: Field.t, r: Region.t): t =
1775 (Apat.Record {flexible = true,
1776 items = Vector.new1 (f, Region.bogus, xField)},
1786 val fromAst = newString o Ast.Con.toString
1793 fun enterLeave (e: t, doit: bool, si): t =
1795 (* Don't create the sourceInfo if we're in the middle of elaborating
1796 * a functor body. Count profiling keeps track of all sourceInfos
1797 * created and would show it with a count of zero, which would be
1800 orelse Env.amInsideFunctor ()
1801 (* Don't create the source info if we're profiling some IL. *)
1802 orelse !Control.profileIL <> Control.ProfileSource
1804 else make (EnterLeave (e, si ()), ty e)
1807 (* This property must be outside of elaborateDec, since we don't want it to
1808 * be created for each call to elaborateDec. If it were, then property lists
1809 * on variables would be littered with lots of these.
1811 val {get = recursiveTargs: Var.t -> (unit -> Type.t vector) option ref,
1813 Property.get (Var.plist, Property.initFun (fn _ => ref NONE))
1815 fun elaborateDec (d, {env = E, nest}) =
1821 !profile <> ProfileNone
1823 fun recursiveFun () =
1825 val boundRef: (unit -> Tyvar.t vector) option ref = ref NONE
1830 NONE => Error.bug "ElaborateCore.elaborateDec: boundRef not set"
1831 | SOME f => Vector.map (f (), Type.var))
1832 fun markFunc func = recursiveTargs func := SOME targs
1833 fun unmarkFunc func = recursiveTargs func := NONE
1834 fun setBound b = boundRef := SOME b
1836 {markFunc = markFunc,
1837 setBound = setBound,
1838 unmarkFunc = unmarkFunc}
1840 fun elabType (t: Atype.t, {bogusAsUnknown}): Type.t =
1841 elaborateType (t, E, {bogusAsUnknown = bogusAsUnknown})
1842 fun elabTypBind (typBind: TypBind.t) =
1844 val TypBind.T types = TypBind.node typBind
1847 (types, fn {def, tycon, tyvars} =>
1849 (tyvars, fn tyvars =>
1850 {scheme = Scheme.make {canGeneralize = true,
1851 ty = elabType (def, {bogusAsUnknown = false}),
1856 (types, fn {scheme, tycon} =>
1858 (E, tycon, TypeStr.def scheme,
1861 (* Rebuild type to propagate tycon equality
1862 * when 'withtype' components of 'datatype' decl. *)
1865 (types, fn {scheme, tycon} =>
1867 val (tyvars, ty) = Scheme.dest scheme
1868 val ty = Type.copy ty
1870 Scheme.make {canGeneralize = true,
1875 (E, tycon, TypeStr.def scheme,
1882 fun elabDatBind (datBind: DatBind.t, nest: string list)
1883 : Decs.t * {tycon: Ast.Tycon.t, typeStr: TypeStr.t} vector =
1884 (* rules 28, 29, 81, 82 *)
1886 val DatBind.T {datatypes, withtypes} = DatBind.node datBind
1887 (* Build enough of an env so that that the withtypes and the
1888 * constructor argument types can be elaborated.
1892 (datatypes, fn {cons, tycon = name, tyvars} =>
1894 val arity = Vector.length tyvars
1895 val k = Kind.Arity arity
1896 val n = Ast.Tycon.toString name
1897 val pd = concat (List.separate (rev (n :: nest), "."))
1898 val r = Ast.Tycon.region name
1900 Tycon.make {admitsEquality = AdmitsEquality.Sometimes,
1905 val _ = Env.extendTycon (E, name, TypeStr.tycon tycon,
1915 val rebindWithtypes = elabTypBind withtypes
1918 (datatypes, fn {arity, cons, name, tycon, tyvars} =>
1922 (cons, fn (name, arg) =>
1924 (tyvars, fn tyvars =>
1925 {arg = Option.map (arg, fn t => elabType (t, {bogusAsUnknown = false})),
1926 con = Con.fromAst name,
1935 (* Maximize equality *)
1936 val change = ref false
1937 fun loop datatypes =
1941 (datatypes, fn {arity, cons, name, tycon} =>
1943 val isEquality = ref true
1946 (cons, fn {arg, con, name, tyvars} =>
1952 (* Rebuild type to propagate tycon equality. *)
1953 val arg = Type.copy arg
1955 Scheme.make {canGeneralize = true,
1959 if Scheme.admitsEquality argScheme
1961 else isEquality := false
1971 datatype z = datatype AdmitsEquality.t
1973 case Tycon.admitsEquality tycon of
1975 Error.bug "ElaborateCore.elaborateDec.elabDatBind: Always"
1980 else (Tycon.setAdmitsEquality (tycon, Never)
1990 then (change := false; loop datatypes)
1993 val datatypes = loop datatypes
1994 val (datatypes, strs) =
1995 (Vector.unzip o Vector.map)
1996 (datatypes, fn {arity, cons, name, tycon} =>
1999 Vector.tabulate (arity, fn _ => Tyvar.makeNoname {equality = false})
2001 Vector.map (tyvars', Type.var)
2003 (Vector.unzip o Vector.map)
2004 (cons, fn {arg, con, name, tyvars} =>
2007 Type.con (tycon, Vector.map (tyvars, Type.var))
2014 Scheme.make {canGeneralize = true,
2017 val arg' = Scheme.apply (argScheme, tyargs')
2020 Type.arrow (arg, res))
2023 Scheme.make {canGeneralize = true,
2033 val cons = Env.newCons (E, cons)
2034 val typeStr = TypeStr.data (tycon, cons)
2047 val () = rebindWithtypes ()
2049 (Decs.single (Cdec.Datatype datatypes), strs)
2051 fun elabDec arg : Decs.t =
2054 Layout.tuple3 (Ast.Dec.layout, Nest.layout, Bool.layout),
2055 Decs.layout, Trace.assertTrue)
2056 (fn (d, nest, isTop) =>
2058 fun ctxt () = seq [str "in: ", approximate (Adec.layout d)]
2059 val region = Adec.region d
2060 fun generalizeError (var, lay, _) =
2063 seq [str "type of variable cannot be generalized in expansive declaration: ",
2065 align [seq [str "type: ", lay],
2067 val () = Time.tick {region = region}
2068 fun checkSchemes (v: (Avar.t * Scheme.t) vector): unit =
2072 if not (Scheme.haveUnknowns s)
2075 (undeterminedTypeChecks, fn () =>
2076 if not (Scheme.haveUnknowns s)
2079 (* Technically, wrong scope for region;
2080 * but saving environment would probably
2083 val (bs, t) = Scheme.dest s
2084 val {layoutPrettyTycon, ...} =
2085 Env.makeLayoutPrettyTycon (E, {prefixUnset = true})
2086 val {layoutPretty = layoutPrettyTyvar,
2087 localInit = localInitLayoutPrettyTyvar, ...} =
2088 Tyvar.makeLayoutPretty ()
2089 val () = localInitLayoutPrettyTyvar bs
2092 (t, {expandOpaque = false,
2093 layoutPrettyTycon = layoutPrettyTycon,
2094 layoutPrettyTyvar = layoutPrettyTyvar})
2098 seq [str "type of variable was not inferred and could not be generalized: ",
2100 align [seq [str "type: ", lay],
2104 fun checkConRedefine (vid, keyword, ctxt) =
2105 case Env.peekLongcon (E, Ast.Longcon.short (Avid.toCon vid)) of
2108 (case valrecConstr () of
2109 Control.Elaborate.DiagEIW.Error => Control.error
2110 | Control.Elaborate.DiagEIW.Ignore => (fn _ => ())
2111 | Control.Elaborate.DiagEIW.Warn => Control.warning)
2113 seq [str "constructor redefined by ",
2118 val elabDec = fn (d, isTop) => elabDec (d, nest, isTop)
2121 Adec.Abstype {datBind, body} => (* rule 19 and p.57 *)
2123 val ((decs, strs), decs') =
2126 fn () => elabDatBind (datBind, nest),
2127 fn z => (z, elabDec (body, isTop)))
2130 (strs, fn {tycon, typeStr} =>
2131 Env.extendTycon (E, tycon, TypeStr.abs typeStr,
2135 Decs.append (decs, decs')
2137 | Adec.Datatype rhs =>
2138 (case DatatypeRhs.node rhs of
2139 DatatypeRhs.DatBind datBind => (* rule 17 *)
2140 #1 (elabDatBind (datBind, nest))
2141 | DatatypeRhs.Repl {lhs, rhs} => (* rule 18 *)
2145 (Env.lookupLongtycon (E, rhs), fn s =>
2148 case TypeStr.node s of
2149 TypeStr.Datatype _ => true
2152 Env.extendTycon (E, lhs, s,
2153 {forceUsed = forceUsed,
2163 val _ = check (ElabControl.allowDoDecls, "do declarations", Adec.region d)
2164 val {unify, ...} = DiagUtils.make E
2165 val exp' = elabExp (exp, nest, NONE)
2168 (Cexp.ty exp', Type.unit, fn (l1, _) =>
2170 str "do declaration expression not of type unit",
2171 align [seq [str "expression: ", l1],
2173 val vb = {ctxt = fn _ => empty,
2175 layPat = fn _ => empty,
2177 pat = Cpat.wild Type.unit,
2178 regionPat = Region.bogus}
2181 (Cdec.Val {matchDiags = matchDiagsFromNoMatch Cexp.Impossible,
2182 rvbs = Vector.new0 (),
2183 tyvars = Vector.new0,
2184 vbs = Vector.new1 vb})
2186 | Adec.Exception ebs =>
2190 (ebs, Decs.empty, fn ((exn, rhs), decs) =>
2193 case EbRhs.node rhs of
2195 (case Env.lookupLongexn (E, c) of
2197 | SOME (exn', scheme) =>
2199 val _ = Env.extendExn (E, exn, exn', scheme)
2205 val exn' = Con.fromAst exn
2208 NONE => (NONE, Type.exn)
2211 val t = elabType (t, {bogusAsUnknown = false})
2214 Type.arrow (t, Type.exn))
2216 val scheme = Scheme.fromType ty
2217 val _ = Env.extendExn (E, exn, exn', scheme)
2220 Cdec.Exception {arg = arg,
2229 | Adec.Fix {ops, fixity} =>
2230 (Vector.foreach (ops, fn op' =>
2231 Env.extendFix (E, op', fixity))
2233 | Adec.Fun {tyvars = tyvars, fbs} =>
2235 val close = TypeEnv.close {region = region}
2238 (tyvars, fn tyvars' =>
2240 val {layoutPrettyTycon, layoutPrettyTyvar, unify, ...} =
2242 val {markFunc, setBound, unmarkFunc} = recursiveFun ()
2245 (fbs, Adec.layoutFun {tyvars = tyvars, fbs = fbs}, fn (clauses, layFb) =>
2247 val ctxtFb = fn () =>
2248 seq [str "in: ", approximate (layFb ())]
2251 (clauses, fn {body, pats, resultType} =>
2254 approximate (Apat.layoutFlatApp pats)
2255 fun layPatsPrefix () =
2256 approximatePrefix (Apat.layoutFlatApp pats)
2259 (Apat.region (Vector.first pats),
2260 Apat.region (Vector.last pats))
2265 (seq [Apat.layoutFlatApp pats,
2268 | SOME rt => seq [str ": ",
2273 Region.append (regionPats, regionBody)
2274 val {args = pats, func} =
2275 Parse.parseClause (pats, E, ctxt)
2279 layClause = layClause,
2281 layPatsPrefix = layPatsPrefix,
2283 regionClause = regionClause,
2284 regionPats = regionPats,
2285 resultType = resultType}
2289 (#regionClause (Vector.first clauses),
2290 #regionClause (Vector.last clauses))
2291 val {pats = pats0, func as func0, layClause = layClause0, ...} =
2292 Vector.first clauses
2293 val layFunc0 = fn () => str (Avar.toString func0)
2294 fun err (reg, msg, desc, layN, lay0) =
2298 align [seq [str desc, approximate (layN ())],
2299 seq [str "previous: ", approximate (lay0 ())],
2303 (clauses, fn {func = funcN, pats = patsN, layClause = layClauseN, regionPats = regionPatsN, ...} =>
2305 val layFuncN = fn () => str (Avar.toString funcN)
2307 if Avar.equals (func, funcN)
2309 else err (Avar.region funcN,
2310 "function clause with different name",
2311 "name: ", layFuncN, layFunc0)
2313 if Vector.length pats0 = Vector.length patsN
2315 else err (regionPatsN,
2316 "function clause with different number of arguments",
2317 "clause: ", layClauseN, layClause0)
2323 (clauses, ~1, fn (r, numArgs) =>
2324 Int.max (Vector.length (#pats r), numArgs))
2330 regionFb = regionFb}
2334 (fbs, [], fn ({func = f, ...}, ac) =>
2335 if List.exists (ac, fn f' => Avar.equals (f, f'))
2339 seq [str "duplicate function definition: ",
2346 (fbs, fn {clauses, ctxtFb, func, numArgs, regionFb} =>
2348 val argTys = Vector.tabulate (numArgs, fn _ => Type.new ())
2349 val resTy = Type.new ()
2352 (clauses, fn {body, layPats, layPatsPrefix, pats, regionPats, resultType, ...} =>
2354 val elaboratePat = elaboratePat ()
2355 val (pats, bindss) =
2356 (Vector.unzip o Vector.mapi)
2357 (pats, fn (i, pat) =>
2359 val regionPat = Apat.region pat
2367 (Vector.sub (argTys, i), Cpat.ty pat, fn (l1, l2) =>
2369 str "function clause with argument of different type",
2370 align [seq [str "argument: ", l2],
2371 seq [str "previous: ", l1],
2376 val binds = Vector.concatV (Vector.rev bindss)
2379 (resultType, fn resultType =>
2381 val regionResultType = Atype.region resultType
2382 val resultType = elabType (resultType, {bogusAsUnknown = true})
2388 str "function clause with result constraint of different type",
2389 align [seq [str "constraint: ", l2],
2390 seq [str "previous: ", l1],
2393 (resultType, regionResultType)
2399 layPatsPrefix = layPatsPrefix,
2401 regionPats = regionPats,
2402 resultType = resultType}
2407 if Type.isUnknown ty
2411 if Vector.forall (argTys, Type.isUnknown)
2412 andalso Type.isUnknown resTy
2414 else Vector.foldr (Vector.map (argTys, chk), chk resTy, Type.arrow)
2416 val funcVid = Avid.fromVar func
2418 Avid.checkRedefineSpecial
2425 (funcVid, "fun", ctxtFb)
2426 val var = Var.fromAst func
2430 Scheme.fromType funTy,
2440 regionFb = regionFb,
2446 (fbs, fn {argTys, clauses, ctxtFb, func, funTy, regionFb, resTy, var, ...} =>
2448 val nest = Avar.toString func :: nest
2449 val resultTypeConstraint = Vector.exists (clauses, Option.isSome o #resultType)
2452 (clauses, fn {binds, body, layPats, layPatsPrefix, pats, regionPats, resultType} =>
2454 val regionBody = Aexp.region body
2459 (binds, fn (x, x', ty) =>
2461 (E, x, x', Scheme.fromType ty,
2462 {isRebind = false}))
2463 ; elabExp (body, nest, NONE)))
2467 profileBody andalso !Control.profileBranch,
2470 {name = ("<case " ^ Layout.toString (layPatsPrefix ()) ^ ">") :: nest,
2471 region = regionBody})
2474 SOME (resultType, regionResultType) =>
2476 (resultType, Cexp.ty body,
2478 (Region.append (regionResultType, regionBody),
2479 seq [if Vector.length clauses = 1
2480 then str "function "
2481 else str "function clause ",
2482 str "expression and result constraint disagree"],
2483 align [seq [str "expression: ", l2],
2484 seq [str "constraint: ", l1],
2487 if resultTypeConstraint
2489 (resTy, Cexp.ty body, fn (l1, l2) =>
2491 str "function clause expression and result constraint disagree",
2492 align [seq [str "expression: ", l2],
2493 seq [str "constraint: ", l1],
2496 (resTy, Cexp.ty body, fn (l1, l2) =>
2498 str "function clause with expression of different type",
2499 align [seq [str "expression: ", l2],
2500 seq [str "previous: ", l1],
2504 layPat = SOME layPats,
2505 pat = Cpat.tuple pats,
2506 regionPat = regionPats}
2510 (argTys, fn argTy =>
2511 (Var.newNoname (), argTy))
2514 (Vector.foldr (argTys, resTy, Type.arrow), funTy, fn (l1, l2) =>
2516 seq [str "recursive use of function disagrees with function declaration type: ",
2518 align [seq [str "recursive use: ", l2],
2519 seq [str "function type: ", l1],
2524 kind = ("function", "clause"),
2526 matchDiags = matchDiagsFromNoMatch Cexp.RaiseMatch,
2527 noMatch = Cexp.RaiseMatch,
2530 test = Cexp.tuple (Vector.map (args, Cexp.var))}
2541 (args, body, fn ((arg, argTy), body) =>
2549 Type.arrow (argTy, Cexp.ty body)))
2551 case Cexp.node lambda of
2552 Cexp.Lambda lambda => lambda
2563 (fbs, fn {check, ...} =>
2565 val {bound, schemes} =
2569 (fbs, fn {func, funTy, ...} =>
2570 {isExpansive = false,
2573 {error = generalizeError,
2574 layoutPrettyTycon = layoutPrettyTycon,
2575 layoutPrettyTyvar = layoutPrettyTyvar})
2579 (Vector.map (fbs, #func),
2581 val _ = setBound bound
2585 fn ({func, var, ...}, scheme) =>
2587 (E, func, var, scheme,
2592 (fbs, fn {lambda, var, ...} =>
2597 (Cdec.Fun {decs = decs,
2601 | Adec.Local (d, d') =>
2606 fn () => elabDec (d, false),
2607 fn decs => Decs.append (decs, elabDec (d', isTop)))
2611 | Adec.Open paths =>
2613 (* The following code is careful to first lookup all of the
2614 * paths in the current environment, and then extend the
2615 * environment with all of the results.
2616 * See rule 22 of the Definition.
2620 (Vector.map (paths, fn p => Env.lookupLongstrid (E, p)),
2621 fn so => Option.app (so, fn s =>
2622 Env.openStructure (E, s)))
2626 | Adec.Overload (p, x, tyvars, ty, xs) =>
2628 (tyvars, fn tyvars' =>
2630 val {unify, ...} = DiagUtils.make E
2631 val () = check (ElabControl.allowOverload, "_overload", region)
2632 (* Lookup the overloads before extending the var in case
2633 * x appears in the xs.
2639 case Env.lookupLongvid (E, x) of
2640 NONE => Vector.new0 ()
2641 | SOME (Vid.Var v, t) =>
2642 Vector.new1 (Longvid.region x, (v, t))
2643 | SOME (Vid.Overload (_, vs), _) =>
2644 Vector.map (vs, fn vt => (Longvid.region x, vt))
2648 str "cannot overload",
2649 seq [str "constructor: ", Longvid.layout x])
2652 Scheme.make {canGeneralize = false,
2654 ty = elabType (ty, {bogusAsUnknown = false})}
2660 val is = Scheme.instantiate s
2661 val is' = Scheme.instantiate s'
2668 str "variant does not unify with overload",
2669 align [seq [str "overload: ", l1],
2670 seq [str "variant: ", l2],
2675 (E, p, x, Vector.map (ovlds, fn (_, vt) => vt), s)
2680 Vector.fold (ds, Decs.empty, fn (d, decs) =>
2681 Decs.append (decs, elabDec (d, isTop)))
2682 | Adec.Type typBind =>
2683 (ignore (elabTypBind typBind)
2685 | Adec.Val {tyvars, rvbs, vbs} =>
2687 val close = TypeEnv.close {region = region}
2690 (tyvars, fn tyvars' =>
2692 val {layoutPrettyTycon, layoutPrettyTyvar, unify, ...} =
2694 val {vbs = layVbs, rvbs = layRvbs} =
2695 Adec.layoutVal {tyvars = tyvars, vbs = vbs, rvbs = rvbs}
2696 (* Must do all the es and rvbs before the ps because of
2701 (vbs, layVbs, fn ({exp, pat, ...}, layVb) =>
2704 seq [str "in: ", approximate (layVb ())]
2705 fun layPat () = Apat.layout pat
2706 val regionPat = Apat.region pat
2707 val regionExp = Aexp.region exp
2708 val exp = elabExp (exp, nest, Apat.getName pat)
2713 andalso !Control.profileVal
2714 andalso Cexp.isExpansive exp, fn () =>
2723 SourceInfo.function {name = name :: nest,
2731 regionExp = regionExp,
2732 regionPat = regionPat}
2734 val {markFunc, setBound, unmarkFunc} = recursiveFun ()
2735 val elaboratePat = elaboratePat ()
2738 (rvbs, layRvbs, fn ({pat, match}, layRvb) =>
2741 seq [str "in: ", approximate (layRvb ())]
2742 val regionPat = Apat.region pat
2744 elaboratePat (pat, E, {bind = false, isRvb = true})
2746 if Vector.length bound = 1
2747 andalso (Type.isUnknown (Cpat.ty pat)
2748 orelse Type.isArrow (Cpat.ty pat))
2750 val (x, x', _) = Vector.first bound
2752 (Avar.toString x :: nest, x')
2754 else ("_" :: nest, Var.newNoname ())
2755 val _ = markFunc var
2758 (bound, fn (x, _, ty) =>
2760 val xVid = Avid.fromVar x
2763 (xVid, "val rec", ctxtRvb)
2766 (E, x, var, Scheme.fromType ty,
2777 regionPat = regionPat,
2778 patIsConstrained = not (Type.isUnknown (Cpat.ty pat)),
2784 fn {ctxtVb, exp, layPat, pat, regionExp, regionPat, ...} =>
2787 elaboratePat (pat, E, {bind = false, isRvb = false})
2790 (Cpat.ty pat, Cexp.ty exp, fn (p, e) =>
2791 (Region.append (regionPat, regionExp),
2792 str "pattern and expression disagree",
2793 align [seq [str "pattern: ", p],
2794 seq [str "expression: ", e],
2802 regionPat = regionPat}
2806 (rvbs, fn {bound, ctxtRvb, match, nest, pat, patIsConstrained, regionPat, var, ...} =>
2808 val {argType, region, resultType, rules} =
2809 elabMatch (match, nest)
2813 Type.arrow (argType, resultType),
2816 then (Region.append (regionPat, Amatch.region match),
2817 str "recursive function pattern and expression disagree",
2818 align [seq [str "pattern: ", l1],
2819 seq [str "expression: ", l2],
2821 else (Avar.region (#1 (Vector.first bound)),
2822 seq [str "recursive use of function disagrees with function expression type: ",
2823 Avar.layout (#1 (Vector.first bound))],
2824 align [seq [str "recursive use: ", l1],
2825 seq [str "function type: ", l2],
2827 val arg = Var.newNoname ()
2830 (Cexp.casee {ctxt = ctxtRvb,
2831 kind = ("recursive function", "rule"),
2833 matchDiags = matchDiagsFromNoMatch Cexp.RaiseMatch,
2834 noMatch = Cexp.RaiseMatch,
2837 test = Cexp.var (arg, argType)},
2839 fn () => SourceInfo.function {name = nest,
2842 Lambda.make {arg = arg,
2854 (rvbs, fn {check, ...} =>
2860 (rvbs, fn {bound, ...} =>
2861 ((Vector.rev o Vector.map)
2863 (z, {isExpansive = false,
2864 isRebind = true}))))),
2867 (vbs, fn {bound, exp, ...} =>
2868 ((Vector.rev o Vector.map)
2870 (z, {isExpansive = Cexp.isExpansive exp,
2871 isRebind = false})))))]
2872 val {bound, schemes} =
2876 (boundVars, fn ((var, _, ty), {isExpansive, ...}) =>
2877 {isExpansive = isExpansive,
2880 {error = generalizeError,
2881 layoutPrettyTycon = layoutPrettyTycon,
2882 layoutPrettyTyvar = layoutPrettyTyvar})
2886 (Vector.map (boundVars, #1 o #1),
2888 val _ = setBound bound
2891 (boundVars, schemes,
2892 fn (((x, x', _), {isRebind, ...}), scheme) =>
2895 {isRebind = isRebind}))
2898 (rvbs, fn {var, ...} =>
2902 (vbs, fn {ctxtVb, exp, layPat, pat, regionPat, ...} =>
2908 regionPat = regionPat})
2911 (rvbs, fn {lambda, var, ...} =>
2914 (* According to page 28 of the Definition, we should
2915 * issue warnings for nonexhaustive valdecs only when it's
2916 * not a top level dec. It seems harmless enough to go
2917 * ahead and always issue them.
2921 (Cdec.Val {matchDiags = matchDiagsFromNoMatch Cexp.RaiseBind,
2928 case resolveScope () of
2929 Control.Elaborate.ResolveScope.Dec =>
2930 (reportUnresolvedFlexRecords ()
2931 ; resolveOverloads ())
2936 and elabExp (arg: Aexp.t * Nest.t * string option) : Cexp.t =
2942 Option.layout String.layout),
2943 Cexp.layoutWithType,
2945 (fn (e: Aexp.t, nest, maybeName) =>
2947 fun elab e = elabExp (e, nest, NONE)
2948 val {layoutPrettyType, layoutPrettyTycon, layoutPrettyTyvar, unify} =
2950 val layoutPrettyTypeBracket = fn ty =>
2951 seq [str "[", #1 (layoutPrettyType ty), str "]"]
2952 fun ctxt () = seq [str "in: ", approximate (Aexp.layout e)]
2953 val unify = fn (a, b, f) =>
2954 unify (a, b, fn z =>
2958 (r, m, align [d, ctxt ()])
2960 val region = Aexp.region e
2963 Aexp.Andalso (el, er) =>
2970 (Cexp.ty ce, Type.bool,
2974 [br, " branch of andalso not of type bool"]),
2975 seq [str "branch: ", l]))
2979 val cel = doit (el, "left")
2980 val cer = doit (er, "right")
2981 val e = Cexp.andAlso (cel, cer)
2983 Cexp.make (Cexp.node e, Type.bool)
2985 | Aexp.App (ef, ea) =>
2990 case Cexp.node cef of
2993 val (argType, resultType) =
2994 case Type.deArrowOpt (Cexp.ty cef) of
2998 val types = (Type.new (), Type.new ())
3000 unify (Cexp.ty cef, Type.arrow types,
3003 then (Aexp.region ef,
3004 str "constant constructor applied to argument",
3005 seq [str "constructor: ", l])
3006 else (Aexp.region ef,
3007 str "function not of arrow type",
3008 seq [str "function: ", l]))
3014 (argType, Cexp.ty cea, fn (l1, l2) =>
3016 seq [str (if isCon then "constructor" else "function"),
3017 str " applied to incorrect argument"],
3018 align [seq [str "expects: ", l1],
3019 seq [str "but got: ", l2]]))
3021 Cexp.make (Cexp.App (cef, cea), resultType)
3023 | Aexp.Case (e, m) =>
3026 val {argType, rules, ...} = elabMatch (m, nest)
3029 (Cexp.ty e, argType, fn (l1, l2) =>
3031 str "case object and match argument disagree",
3032 align [seq [str "case object: ", l1],
3033 seq [str "match argument: ", l2]]))
3035 Cexp.casee {ctxt = ctxt,
3036 kind = ("case", "rule"),
3038 matchDiags = matchDiagsFromNoMatch Cexp.RaiseMatch,
3039 noMatch = Cexp.RaiseMatch,
3040 region = Amatch.region m,
3047 {layoutPrettyType = #1 o layoutPrettyType},
3048 fn (resolve, ty) => Cexp.make (Cexp.Const resolve, ty),
3049 {false = Cexp.falsee,
3051 | Aexp.Constraint (e, t') =>
3054 val t' = elabType (t', {bogusAsUnknown = true})
3057 (Cexp.ty e, t', fn (l1, l2) =>
3059 str "expression and constraint disagree",
3060 align [seq [str "expression: ", l1],
3061 seq [str "constraint: ", l2]]))
3063 Cexp.make (Cexp.node e, t')
3065 | Aexp.FlatApp items => elab (Parse.parseExp (items, E, ctxt))
3070 NONE => "fn" :: nest
3071 | SOME s => s :: nest
3072 val {arg, argType, body} =
3075 ("function", "rule"), Cexp.RaiseMatch)
3080 fn () => SourceInfo.function {name = nest,
3083 Cexp.make (Cexp.Lambda (Lambda.make {arg = arg,
3087 Type.arrow (argType, Cexp.ty body))
3089 | Aexp.Handle (try, match) =>
3092 val {arg, argType, body} =
3095 ("handler", "rule"), Cexp.RaiseAgain)
3098 (Cexp.ty try, Cexp.ty body, fn (l1, l2) =>
3100 str "expression and handler disagree",
3101 align [seq [str "expression: ", l1],
3102 seq [str "handler: ", l2]]))
3105 (argType, Type.exn, fn (l1, _) =>
3106 (Amatch.region match,
3107 str "handler match argument not of type exn",
3108 seq [str "argument: ", l1]))
3110 Cexp.make (Cexp.Handle {catch = (arg, Type.exn),
3115 | Aexp.If (a, b, c) =>
3122 (Cexp.ty a', Type.bool, fn (l1, _) =>
3124 str "if test not of type bool",
3125 seq [str "test: ", l1]))
3128 (Cexp.ty b', Cexp.ty c', fn (l1, l2) =>
3130 str "then and else branches disagree",
3131 align [seq [str "then: ", l1],
3132 seq [str "else: ", l2]]))
3134 if not (!Control.profileBranch)
3138 fun wrap (e, e', name) =
3140 (e', profileBody, fn () =>
3142 {name = name :: nest,
3143 region = Aexp.region e})
3145 (wrap (b, b', "<case true>"), wrap (c, c', "<case false>"))
3148 Cexp.iff (a', b', c')
3150 | Aexp.Let (d, e) =>
3156 val time = Time.now ()
3157 val d' = Decs.toVector (elabDec (d, nest, false))
3161 case Type.checkTime (ty, time,
3162 {layoutPrettyTycon = layoutPrettyTycon,
3163 layoutPrettyTyvar = layoutPrettyTyvar}) of
3165 | SOME (lay, ty, {tycons, ...}) =>
3170 (c, layoutPrettyTycon c))
3173 (tycons, fn ((_, l1), (_, l2)) =>
3174 String.<= (Layout.toString l1,
3175 Layout.toString l2))
3179 seq [str "type of let has ",
3180 if List.length tycons > 1
3181 then str "local types that would escape their scope: "
3182 else str "local type that would escape its scope: ",
3183 seq (Layout.separate (List.map (tycons, #2), ", "))],
3184 align [seq [str "type: ", lay],
3186 (tycons, fn (c, _) =>
3187 seq [str "escape from: ",
3188 Region.layout (Tycon.region c)]),
3194 Cexp.make (Cexp.Let (d', e'), ty)
3201 val es' = Vector.map (es, elab)
3203 Cexp.make (Cexp.List es',
3205 (Vector.map2 (es, es', fn (e, e') =>
3206 (Cexp.ty e', Aexp.region e)),
3209 | Aexp.Orelse (el, er) =>
3216 (Cexp.ty ce, Type.bool,
3220 [br, " branch of orelse not of type bool"]),
3221 seq [str "branch: ", l]))
3225 val cel = doit (el, "left")
3226 val cer = doit (er, "right")
3227 val e = Cexp.orElse (cel, cer)
3229 Cexp.make (Cexp.node e, Type.bool)
3231 | Aexp.Paren e => elab e
3234 fun elabAndExpandTy ty =
3236 val elabedTy = elabType (ty, {bogusAsUnknown = false})
3239 (elabedTy, {con = Type.con,
3240 expandOpaque = true,
3241 record = Type.record,
3242 replaceSynonyms = false,
3245 (elabedTy, expandedTy)
3247 (* We use expandedTy to get the underlying primitive right
3248 * but we use wrap in the end to make the result of the
3249 * final expression be ty, because that is what the rest
3250 * of the code expects to see.
3252 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
3253 fun etaExtraNoWrap {expandedTy,
3255 prim: Type.t Prim.t}: Cexp.t =
3256 case Type.deArrowOpt expandedTy of
3257 NONE => primApp {args = extra,
3259 result = expandedTy}
3260 | SOME (argType, bodyType) =>
3262 val arg = Var.newNoname ()
3264 primApp {args = Vector.concat [extra, args],
3268 case Type.deTupleOpt argType of
3271 (Cexp.var (arg, argType)))
3277 (Var.newNoname (), t))
3280 {ctxt = fn _ => empty,
3283 matchDiags = matchDiagsFromNoMatch Cexp.Impossible,
3284 noMatch = Cexp.Impossible,
3285 region = Region.bogus,
3287 {exp = app (Vector.map
3293 regionPat = Region.bogus},
3294 test = Cexp.var (arg, argType)}
3297 (Cexp.lambda o Lambda.make)
3303 fun etaNoWrap {expandedTy,
3304 prim: Type.t Prim.t} : Cexp.t =
3305 etaExtraNoWrap {expandedTy = expandedTy,
3306 extra = Vector.new0 (),
3308 fun eta {elabedTy, expandedTy,
3309 prim: Type.t Prim.t} : Cexp.t =
3310 wrap (etaNoWrap {expandedTy = expandedTy,
3313 fun lookConst {default: string option,
3314 elabedTy, expandedTy,
3322 seq [str "strange constant type: ",
3323 Type.layout expandedTy],
3326 Error.bug "ElaborateCore.elabExp.lookConst"
3329 case Type.deConOpt expandedTy of
3334 if Tycon.equals (c, Tycon.bool)
3336 else if Tycon.isIntX c
3337 then case Tycon.deIntX c of
3341 (WordSize.fromBits (IntSize.bits is))
3342 else if Tycon.isRealX c
3343 then ConstType.Real (Tycon.deRealX c)
3344 else if Tycon.isWordX c
3345 then ConstType.Word (Tycon.deWordX c)
3346 else if Tycon.equals (c, Tycon.vector)
3347 andalso 1 = Vector.length ts
3349 (case (Type.deConOpt
3350 (Vector.first ts)) of
3354 andalso (Tycon.deCharX c = CharSize.C8))
3355 then ConstType.String
3358 fn () => ! Const.lookup ({default = default,
3361 Cexp.make (Cexp.Const finish, elabedTy)
3364 val check = fn (c, n) => check (c, n, region)
3365 datatype z = datatype Ast.PrimKind.t
3368 Address {attributes, name, ty} =>
3371 check (ElabControl.allowFFI, "_address")
3372 val (elabedTy, expandedTy) =
3375 address {attributes = attributes,
3376 elabedTy = elabedTy,
3377 expandedTy = expandedTy,
3380 layoutPrettyType = #1 o layoutPrettyType}
3382 | BuildConst {name, ty} =>
3385 check (ElabControl.allowConstant,
3387 val (elabedTy, expandedTy) =
3390 lookConst {default = NONE,
3391 elabedTy = elabedTy,
3392 expandedTy = expandedTy,
3395 | CommandLineConst {name, ty, value} =>
3398 check (ElabControl.allowConstant,
3399 "_command_line_const")
3400 val (elabedTy, expandedTy) =
3405 {layoutPrettyType = #1 o layoutPrettyType},
3409 IntInf.toString (WordX.toIntInf w)
3410 | c => Const.toString c,
3411 {false = "false", true = "true"})
3413 lookConst {default = SOME value,
3414 elabedTy = elabedTy,
3415 expandedTy = expandedTy,
3418 | Const {name, ty} =>
3421 check (ElabControl.allowConstant,
3423 val (elabedTy, expandedTy) =
3426 lookConst {default = NONE,
3427 elabedTy = elabedTy,
3428 expandedTy = expandedTy,
3431 | Export {attributes, name, ty} =>
3434 check (ElabControl.allowFFI, "_export")
3435 val (elabedTy, expandedTy) =
3440 str "invalid type for _export",
3441 #1 (layoutPrettyType elabedTy))
3442 val (expandedCfTy, elabedExportTy) =
3446 val error = fn () =>
3448 ; ignore (escape (Type.arrow (Type.unit, Type.unit),
3450 ; Error.bug "ElaborateCore.elabExp.Export.escape")
3452 case Type.deArrowOpt expandedTy of
3454 | SOME (argTy, resTy) =>
3455 (case Type.deArrowOpt argTy of
3460 if Type.isUnit resTy
3471 (E, valOf (!Env.Structure.ffi))
3472 ; elab (export {attributes = attributes,
3473 elabedTy = elabedTy,
3474 expandedTy = expandedCfTy,
3477 layoutPrettyType = #1 o layoutPrettyType})))
3481 Type.arrow (expandedCfTy, Type.unit),
3484 str "_export unify bug",
3485 align [seq [str "inferred: ", l1],
3486 seq [str "expanded: ", l2]]))
3488 wrap (exp, elabedExportTy)
3490 | IImport {attributes, ty} =>
3493 check (ElabControl.allowFFI, "_import")
3494 val (elabedTy, expandedTy) =
3499 str "invalid type for _import",
3500 #1 (layoutPrettyType elabedTy))
3501 val (expandedFPtrTy, expandedCfTy) =
3505 val error = fn () =>
3507 ; ignore (escape (Type.cpointer,
3508 Type.arrow (Type.unit, Type.unit)))
3509 ; Error.bug "ElaborateCore.elabExp.IImport.escape")
3511 case Type.deArrowOpt expandedTy of
3513 | SOME (fptrTy, cfTy) => (fptrTy, cfTy)
3516 case Type.toCPtrType expandedFPtrTy of
3517 NONE => (error (); ())
3519 val fptr = Var.newNoname ()
3520 val fptrArg = Cexp.var (fptr, expandedFPtrTy)
3523 ((Cexp.lambda o Lambda.make)
3525 argType = expandedFPtrTy,
3526 body = etaExtraNoWrap {expandedTy = expandedCfTy,
3527 extra = Vector.new1 fptrArg,
3529 {attributes = attributes,
3532 elabedTy = elabedTy,
3533 expandedTy = expandedCfTy,
3534 layoutPrettyType = #1 o layoutPrettyType}},
3538 | Import {attributes, name, ty} =>
3541 check (ElabControl.allowFFI, "_import")
3542 val (elabedTy, expandedTy) =
3545 eta ({elabedTy = elabedTy,
3546 expandedTy = expandedTy,
3547 prim = import {attributes = attributes,
3550 elabedTy = elabedTy,
3551 expandedTy = expandedTy,
3552 layoutPrettyType = #1 o layoutPrettyType}})
3557 check (ElabControl.allowFFI, "_symbol")
3558 val (elabedTy, expandedTy) =
3561 symbolIndirect {elabedTy = elabedTy,
3562 expandedTy = expandedTy,
3564 layoutPrettyType = #1 o layoutPrettyType}
3566 | Prim {name, ty} =>
3569 check (ElabControl.allowPrim,
3571 val (elabedTy, expandedTy) =
3574 case Prim.fromString name of
3578 str (concat ["unknown primitive: ",
3584 eta {elabedTy = elabedTy,
3585 expandedTy = expandedTy,
3588 | Symbol {attributes, name, ty} =>
3591 check (ElabControl.allowFFI, "_symbol")
3592 val (elabedTy, expandedTy) =
3595 symbolDirect {attributes = attributes,
3596 elabedTy = elabedTy,
3597 expandedTy = expandedTy,
3600 layoutPrettyType = #1 o layoutPrettyType}
3605 val region = Aexp.region exn
3609 (Cexp.ty exn, Type.exn, fn (l1, _) =>
3611 str "raise object not of type exn",
3612 seq [str "object: ", l1]))
3613 val resultType = Type.new ()
3616 (Cexp.make (Cexp.Raise exn, resultType),
3617 profileBody andalso !Control.profileRaise,
3618 fn () => SourceInfo.function {name = "<raise>" :: nest,
3623 val r = Record.map (r, elab o #2)
3626 (SortedRecord.fromVector
3627 (Record.toVector (Record.map (r, Cexp.ty))))
3629 Cexp.make (Cexp.Record r, ty)
3631 | Aexp.Selector f => elab (Aexp.selector (f, region))
3634 val es' = Vector.map (es, elab)
3635 val last = Vector.length es - 1
3636 (* Diagnose expressions before a ; that don't return unit. *)
3639 (* Technically, wrong scope for region;
3640 * but saving environment would probably
3645 (es, es', fn (i, e, e') =>
3646 if i = last orelse Type.isUnit (Cexp.ty e')
3649 (sequenceNonUnitChecks, fn () =>
3650 if Type.isUnit (Cexp.ty e')
3652 else f (Aexp.region e,
3653 str "sequence expression not of type unit",
3654 align [seq [str "type: ", layoutPrettyTypeBracket (Cexp.ty e')],
3657 case sequenceNonUnit () of
3658 Control.Elaborate.DiagEIW.Error => doit Control.error
3659 | Control.Elaborate.DiagEIW.Ignore => ()
3660 | Control.Elaborate.DiagEIW.Warn => doit Control.warning
3663 Cexp.make (Cexp.Seq es', Cexp.ty (Vector.sub (es', last)))
3665 | Aexp.Var {name = id, ...} =>
3668 Cexp.var (Var.newNoname (), Type.new ())
3670 case Env.lookupLongvid (E, id) of
3672 | SOME (vid, scheme) =>
3674 val {args, instance} = Scheme.instantiate scheme
3675 fun con c = Cexp.Con (c, args ())
3679 | Vid.Exn c => con c
3680 | Vid.Overload (p, yts) =>
3689 val is = Scheme.instantiate s
3692 (instance, #instance is)
3693 then SOME (x, SOME is)
3698 (* Technically, wrong scope for region;
3699 * but saving environment would probably
3705 seq [str "variable not overloaded at type: ",
3706 str (Longvid.toString id)],
3707 seq [str "type: ", #1 (layoutPrettyType instance)])
3709 {id = Var.newNoname (),
3710 args = Vector.new0 ()}
3714 #instance (valOf is), fn _ =>
3715 Error.bug "ElaborateCore.elabExp: Var:overload unify")
3716 ; {id = y, args = #args (valOf is) ()}))
3718 List.push (overloadChecks, (p, ignore o resolve))
3720 Cexp.Var (#id o resolve, #args o resolve)
3723 Cexp.Var (fn () => x,
3724 case ! (recursiveTargs x) of
3728 Cexp.make (e, instance)
3733 val _ = check (ElabControl.allowVectorExps, "Vector expressions", Aexp.region e)
3734 val es' = Vector.map (es, elab)
3736 Cexp.make (Cexp.Vector es',
3738 (Vector.map2 (es, es', fn (e, e') =>
3739 (Cexp.ty e', Aexp.region e)),
3742 | Aexp.While {expr, test} =>
3744 val test' = elab test
3747 (Cexp.ty test', Type.bool, fn (l1, _) =>
3749 str "while test not of type bool",
3750 seq [str "test: ", l1]))
3751 val expr' = elab expr
3752 (* Diagnose if expr is not of type unit. *)
3755 (* Technically, wrong scope for region;
3756 * but saving environment would probably
3760 if Type.isUnit (Cexp.ty expr')
3763 (sequenceNonUnitChecks, fn () =>
3764 if Type.isUnit (Cexp.ty expr')
3766 else f (Aexp.region expr,
3767 str "while body not of type unit",
3768 align [seq [str "body: ", layoutPrettyTypeBracket (Cexp.ty expr')],
3771 case sequenceNonUnit () of
3772 Control.Elaborate.DiagEIW.Error => doit Control.error
3773 | Control.Elaborate.DiagEIW.Ignore => ()
3774 | Control.Elaborate.DiagEIW.Warn => doit Control.warning
3777 Cexp.whilee {expr = expr', test = test'}
3780 and elabMatchFn (m: Amatch.t, nest, ctxt, kind, noMatch) =
3782 val arg = Var.newNoname ()
3783 val {argType, region, rules, ...} = elabMatch (m, nest)
3785 Cexp.casee {ctxt = ctxt,
3788 matchDiags = matchDiagsFromNoMatch noMatch,
3792 test = Cexp.var (arg, argType)}
3798 and elabMatch (m: Amatch.t, nest: Nest.t) =
3800 val {unify, ...} = DiagUtils.make E
3802 seq [str "in: ", approximate (Amatch.layout m)]
3803 val unify = fn (a, b, f) =>
3804 unify (a, b, fn z =>
3808 (r, m, align [d, ctxt ()])
3810 val region = Amatch.region m
3811 val Amatch.T rules = Amatch.node m
3812 val argType = Type.new ()
3813 val resultType = Type.new ()
3816 (rules, fn (pat, exp) =>
3820 fun layPat () = approximate (Apat.layout pat)
3823 elaboratePat () (pat, E, {bind = true, isRvb = false})
3826 (Cpat.ty pat, argType, fn (l1, l2) =>
3827 (Apat.region patOrig,
3828 str "rule with pattern of different type",
3829 align [seq [str "pattern: ", l1],
3830 seq [str "previous: ", l2]]))
3832 val exp = elabExp (exp, nest, NONE)
3835 (Cexp.ty exp, resultType, fn (l1, l2) =>
3836 (Aexp.region expOrig,
3837 str "rule with result of different type",
3838 align [seq [str "result: ", l1],
3839 seq [str "previous: ", l2]]))
3843 profileBody andalso !Control.profileBranch,
3850 (Apat.layout patOrig)),
3853 SourceInfo.function {name = name :: nest,
3854 region = Aexp.region expOrig}
3858 layPat = SOME layPat,
3860 regionPat = Apat.region patOrig}
3865 resultType = resultType,
3868 val ds = elabDec (Scope.scope d, nest, true)