HCoop / hcoop / debian / mlton.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Import Debian changes 20180207-1
[hcoop/debian/mlton.git] / mlton / elaborate / elaborate-core.fun
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.
5 *
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
8 *)
9
10 functor ElaborateCore (S: ELABORATE_CORE_STRUCTS): ELABORATE_CORE =
11 struct
12
13 open S
14
15 local
16 open Control.Elaborate
17 in
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) =
31 if current c
32 then ()
33 else
34 let
35 open Layout
36 in
37 Control.error
38 (region,
39 str (concat (if expert c
40 then [keyword, " disallowed"]
41 else [keyword, " disallowed, compile with -default-ann '",
42 name c, " true'"])),
43 empty)
44 end
45 end
46 structure ElabControl = Control.Elaborate
47
48
49 local
50 open Layout
51 in
52 val align = align
53 val empty = empty
54 val seq = seq
55 val str = str
56 end
57
58 fun approximateN (l: Layout.t, prefixMax, suffixMax): Layout.t =
59 let
60 val s = Layout.toString l
61 val n = String.size s
62 in
63 str
64 (case suffixMax of
65 NONE =>
66 if n <= prefixMax
67 then s
68 else concat [String.prefix (s, prefixMax - 5), " ..."]
69 | SOME suffixMax =>
70 if n <= prefixMax + suffixMax
71 then s
72 else concat [String.prefix (s, prefixMax - 2),
73 " ... ",
74 String.suffix (s, suffixMax - 5)])
75 end
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)
80
81 local
82 open Ast
83 in
84 structure Aconst = Const
85 structure Adec = Dec
86 structure Aexp = Exp
87 structure Amatch = Match
88 structure Apat = Pat
89 structure Atype = Type
90 structure Avar = Var
91 structure Avid = Vid
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
106 end
107
108 local
109 open Env
110 in
111 structure Kind = Kind
112 structure TypeEnv = TypeEnv
113 structure TypeStr = TypeStr
114 structure TyvarEnv = TyvarEnv
115 structure Vid = Vid
116 end
117
118 local
119 open TypeEnv
120 in
121 structure Scheme = Scheme
122 structure Time = Time
123 structure Type = Type
124 end
125
126 local
127 open CoreML
128 in
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
135 structure Con = Con
136 structure Const = Const
137 structure ConstType = Const.ConstType
138 structure Cdec = Dec
139 structure Cexp = Exp
140 structure Ffi = Ffi
141 structure IntSize = IntSize
142 structure Lambda = Lambda
143 structure Cpat = Pat
144 structure Prim = Prim
145 structure RealSize = RealSize
146 structure RealX = RealX
147 structure SourceInfo = SourceInfo
148 structure Tycon = Tycon
149 structure Tyvar = Tyvar
150 structure Var = Var
151 structure WordSize = WordSize
152 structure WordX = WordX
153 structure WordXVector = WordXVector
154 end
155 structure Tycon =
156 struct
157 open Tycon
158 open TypeEnv.TyconExt
159 end
160 structure Tyvar =
161 struct
162 open Tyvar
163 open TypeEnv.TyvarExt
164 end
165
166 fun matchDiagsFromNoMatch noMatch =
167 case noMatch of
168 Cexp.Impossible =>
169 {nonexhaustiveExn = Control.Elaborate.DiagDI.Default,
170 nonexhaustive = Control.Elaborate.DiagEIW.Ignore,
171 redundant = Control.Elaborate.DiagEIW.Ignore}
172 | Cexp.RaiseAgain =>
173 {nonexhaustiveExn = nonexhaustiveExnRaise (),
174 nonexhaustive = nonexhaustiveRaise (),
175 redundant = redundantRaise ()}
176 | Cexp.RaiseBind =>
177 {nonexhaustiveExn = nonexhaustiveExnBind (),
178 nonexhaustive = nonexhaustiveBind (),
179 redundant = redundantBind ()}
180 | Cexp.RaiseMatch =>
181 {nonexhaustiveExn = nonexhaustiveExnMatch (),
182 nonexhaustive = nonexhaustiveMatch (),
183 redundant = redundantMatch ()}
184
185 structure AdmitsEquality = Tycon.AdmitsEquality
186
187 local
188 open Record
189 in
190 structure Field = Field
191 end
192
193 structure Parse = PrecedenceParse (structure Ast = Ast
194 structure Env = Env)
195
196 structure Scope = Scope (structure Ast = Ast)
197
198 structure Apat =
199 struct
200 open Apat
201
202 fun getName (p: t): string option =
203 case node p of
204 Var {name, ...} => SOME (Longvid.toString name)
205 | Constraint (p, _) => getName p
206 | FlatApp v =>
207 if 1 = Vector.length v
208 then getName (Vector.first v)
209 else NONE
210 | Layered {var, ...} => SOME (Avar.toString var)
211 | _ => NONE
212
213 val getName =
214 Trace.trace ("ElaborateCore.Apat.getName", layout, Option.layout String.layout)
215 getName
216 end
217
218 fun elaborateType (ty: Atype.t, E: Env.t,
219 {bogusAsUnknown: bool}): Type.t =
220 let
221 fun makeBogus (mc, ts) =
222 if bogusAsUnknown
223 then Type.new ()
224 else let
225 val arity = Vector.length ts
226 val (name, region) =
227 Option.fold
228 (mc, ("t", NONE), fn (c, _) =>
229 (Longtycon.toString c,
230 SOME (Longtycon.region c)))
231 val c =
232 Tycon.makeBogus
233 {name = name,
234 kind = Kind.Arity arity,
235 region = region}
236 in
237 Type.con (c, ts)
238 end
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 *)
246 let
247 val ts = Vector.map (ts, loop)
248 fun normal () =
249 case Env.lookupLongtycon (E, c) of
250 NONE => makeBogus (SOME c, ts)
251 | SOME s =>
252 let
253 val kind = TypeStr.kind s
254 val numArgs = Vector.length ts
255 val ts =
256 case kind of
257 Kind.Arity n =>
258 let
259 fun error () =
260 let
261 open Layout
262 fun doit n =
263 seq [str "[",
264 case n of
265 0 => empty
266 | 1 => str "_"
267 | _ => seq [str "(",
268 (seq o separate)
269 (List.tabulate (n, fn _ => str "_"),
270 ", "),
271 str ")"],
272 str "] ",
273 Ast.Longtycon.layout c]
274 in
275 Control.error
276 (Atype.region ty,
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]])
282 end
283 in
284 case Int.compare (n, numArgs) of
285 LESS =>
286 (error (); Vector.prefix (ts, n))
287 | EQUAL => ts
288 | GREATER =>
289 (error ()
290 ; Vector.concat
291 [ts,
292 Vector.tabulate
293 (n - numArgs, fn _ =>
294 makeBogus
295 (NONE, Vector.new0 ()))])
296 end
297 | Kind.Nary => ts
298 in
299 TypeStr.apply (s, ts)
300 end
301 in
302 case (Ast.Longtycon.split c, Vector.length ts) of
303 (([], c), 2) =>
304 if Ast.Tycon.equals (c, Ast.Tycon.arrow)
305 then Type.arrow (Vector.sub (ts, 0),
306 Vector.sub (ts, 1))
307 else normal ()
308 | _ => normal ()
309 end
310 | Atype.Paren t => loop t
311 | Atype.Record r => (* rules 45, 49 *)
312 Type.record
313 (SortedRecord.fromVector
314 (Vector.map
315 (Record.toVector r,
316 fn (f, (_, t)) => (f, loop t))))
317 in
318 loop ty
319 end
320
321 val overloadChecks: (Ast.Priority.t * (unit -> unit)) list ref = ref []
322
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)),
328 fn (_,th) => th ())
329 ; overloadChecks := [])
330
331 val unresolvedFlexRecordChecks: (unit -> unit) list ref = ref []
332
333 fun reportUnresolvedFlexRecords () =
334 (List.foreach (rev (!unresolvedFlexRecordChecks), fn th => th ())
335 ; unresolvedFlexRecordChecks := [])
336
337 val undeterminedTypeChecks: (unit -> unit) list ref = ref []
338
339 fun reportUndeterminedTypes () =
340 (List.foreach (rev (!undeterminedTypeChecks), fn th => th ())
341 ; undeterminedTypeChecks := [])
342
343 val sequenceNonUnitChecks: (unit -> unit) list ref = ref []
344
345 fun reportSequenceNonUnit () =
346 (List.foreach (rev (!sequenceNonUnitChecks), fn th => th ())
347 ; sequenceNonUnitChecks := [])
348
349 val {hom = typeTycon: Type.t -> Tycon.t option, ...} =
350 Type.makeHom {con = fn (c, _) => SOME c,
351 expandOpaque = false,
352 var = fn _ => NONE}
353
354 val typeTycon =
355 Trace.trace
356 ("ElaborateCore.typeTycon", Type.layout, Option.layout Tycon.layout)
357 typeTycon
358
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 =
363 let
364 fun error (kind: string, ty: Type.t): unit =
365 Control.error
366 (Aconst.region c,
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>"
372 | SOME s => make s
373 fun delay (ty: unit -> Type.t, resolve: Type.t -> Const.t): 'a =
374 let
375 val ty = ty ()
376 val resolve = Promise.lazy (fn () => resolve ty)
377 val _ = List.push (overloadChecks, (Priority.default, ignore o resolve))
378 in
379 make (resolve, ty)
380 end
381 val typeTycon =
382 fn ty =>
383 case typeTycon ty of
384 NONE => Tycon.bogus
385 | SOME c => c
386 in
387 case Aconst.node c of
388 Aconst.Bool b => if b then t else f
389 | Aconst.Char ch =>
390 delay
391 (Type.unresolvedChar, fn ty =>
392 choose (typeTycon ty,
393 CharSize.all,
394 Tycon.word o WordSize.fromBits o CharSize.bits,
395 fn cs =>
396 let
397 val ws = WordSize.fromBits (CharSize.bits cs)
398 in
399 Const.Word
400 (if CharSize.isInRange (cs, ch)
401 then WordX.fromIntInf (ch, ws)
402 else (error ("char constant", ty); WordX.zero ws))
403 end))
404 | Aconst.Int i =>
405 delay
406 (Type.unresolvedInt, fn ty =>
407 let
408 val tycon = typeTycon ty
409 in
410 if Tycon.equals (tycon, Tycon.intInf)
411 then Const.IntInf i
412 else
413 choose (tycon, WordSize.all, Tycon.word, fn s =>
414 Const.Word
415 (if WordSize.isInRange (s, i, {signed = true})
416 then WordX.fromIntInf (i, s)
417 else (error ("int constant", ty); WordX.zero s)))
418 end)
419 | Aconst.Real r =>
420 delay
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)
425 | SOME r => r)))
426 | Aconst.String v =>
427 delay
428 (Type.unresolvedString, fn ty =>
429 choose (typeTycon (Type.deVector ty),
430 CharSize.all,
431 Tycon.word o WordSize.fromBits o CharSize.bits,
432 fn cs =>
433 let
434 val ws = WordSize.fromBits (CharSize.bits cs)
435 val bigs = ref []
436 val wv =
437 Const.WordVector
438 (WordXVector.tabulate
439 ({elementSize = ws}, Vector.length v, fn i =>
440 let
441 val ch = Vector.sub (v, i)
442 in
443 if CharSize.isInRange (cs, ch)
444 then WordX.fromIntInf (ch, ws)
445 else (List.push (bigs, ch)
446 ; WordX.zero ws)
447 end))
448 val () =
449 if List.isEmpty (!bigs)
450 then ()
451 else Control.error
452 (Aconst.region c,
453 seq [str "string constant with ",
454 str (case !bigs of
455 [_] => "character "
456 | _ => "characters "),
457 str "too large for type: ",
458 seq (Layout.separate
459 (List.revMap
460 (!bigs, fn ch =>
461 Aconst.layout (Aconst.makeRegion (Aconst.Char ch, Region.bogus))),
462 ", "))],
463 seq [str "type: ", layoutPrettyType ty])
464 in
465 wv
466 end))
467 | Aconst.Word w =>
468 delay
469 (Type.unresolvedWord, fn ty =>
470 choose (typeTycon ty, WordSize.all, Tycon.word, fn s =>
471 Const.Word
472 (if WordSize.isInRange (s, w, {signed = false})
473 then WordX.fromIntInf (w, s)
474 else (error ("word constant", ty); WordX.zero s))))
475 end
476
477 local
478 fun unifySeq (seqTy, seqStr,
479 trs: (Type.t * Region.t) vector,
480 unify): Type.t =
481 if Vector.isEmpty trs
482 then seqTy (Type.new ())
483 else
484 let
485 val (t, _) = Vector.first trs
486 val _ =
487 Vector.foreach
488 (trs, fn (t', r) =>
489 unify (t, t', fn (l, l') =>
490 (r,
491 str (seqStr ^ " with element of different type"),
492 align [seq [str "element: ", l'],
493 seq [str "previous: ", l]])))
494 in
495 seqTy t
496 end
497 in
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)
502 end
503
504 val elabPatInfo = Trace.info "ElaborateCore.elabPat"
505
506 structure Var =
507 struct
508 open Var
509
510 val fromAst = newString o Avar.toString
511 end
512
513 structure DiagUtils =
514 struct
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}
519 fun make E : t =
520 let
521 val {layoutPrettyTycon, ...} =
522 Env.makeLayoutPrettyTycon (E, {prefixUnset = true})
523 val {layoutPretty = layoutPrettyTyvar, ...} =
524 TyvarEnv.makeLayoutPretty ()
525 val layoutPrettyType = fn t =>
526 Type.layoutPretty
527 (t, {expandOpaque = false,
528 layoutPrettyTycon = layoutPrettyTycon,
529 layoutPrettyTyvar = layoutPrettyTyvar})
530 fun unify (t, t', error) =
531 let
532 val error = fn (l, l', {notes}) =>
533 let
534 val (r, m, d) = error (l, l')
535 in
536 Control.error
537 (r, m, align [d, notes ()])
538 end
539 in
540 Type.unify
541 (t, t', {error = error,
542 layoutPretty = layoutPrettyType,
543 layoutPrettyTycon = layoutPrettyTycon,
544 layoutPrettyTyvar = layoutPrettyTyvar})
545 end
546 in
547 {layoutPrettyType = layoutPrettyType,
548 layoutPrettyTycon = layoutPrettyTycon,
549 layoutPrettyTyvar = layoutPrettyTyvar,
550 unify = unify}
551 end
552 end
553
554 val elaboratePat:
555 unit
556 -> Apat.t * Env.t * {bind: bool, isRvb: bool}
557 -> Cpat.t * (Avar.t * Var.t * Type.t) vector =
558 fn () =>
559 let
560 val others: (Apat.t * (Avar.t * Var.t * Type.t) vector) list ref = ref []
561 in
562 fn (p: Apat.t, E: Env.t, {bind = bindInEnv, isRvb}) =>
563 let
564 val {layoutPrettyType, unify, ...} = DiagUtils.make E
565 fun ctxtTop () =
566 seq [str "in: ", approximate (Apat.layout p)]
567 val rename =
568 let
569 val renames: (Avar.t * Var.t) list ref = ref []
570 in
571 fn x =>
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')
575 end
576 | SOME (_, x') => x'
577 end
578 val xts: (Avar.t * Var.t * Type.t) list ref = ref []
579 fun bindToType (x: Avar.t, t: Type.t): Var.t =
580 let
581 val _ =
582 Avid.checkRedefineSpecial
583 (Avid.fromVar x,
584 {allowIt = true,
585 ctxt = ctxtTop,
586 keyword = if isRvb then "val rec" else "pattern"})
587 val x' = rename x
588 val () =
589 case List.peek (!xts, fn (y, _, _) => Avar.equals (x, y)) of
590 NONE => ()
591 | SOME _ =>
592 Control.error
593 (Avar.region x,
594 seq [str "duplicate variable in pattern: ", Avar.layout x],
595 ctxtTop ())
596 val _ = List.push (xts, (x, x', t))
597 in
598 x'
599 end
600 fun bind (x: Avar.t): Var.t * Type.t =
601 let
602 val t = Type.new ()
603 in
604 (bindToType (x, t), t)
605 end
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)
610 (fn (p: Apat.t) =>
611 let
612 val region = Apat.region p
613 fun ctxt () =
614 seq [str "in: ", approximate (Apat.layout p)]
615 val unify = fn (a, b, f) =>
616 unify (a, b, fn z =>
617 let
618 val (r, m, d) = f z
619 in
620 (r, m, align [d, ctxt ()])
621 end)
622 fun unifyPatternConstraint (p, c) =
623 unify
624 (p, c, fn (l1, l2) =>
625 (region,
626 str "pattern and constraint disagree",
627 align [seq [str "pattern: ", l1],
628 seq [str "constraint: ", l2]]))
629 fun dontCare () =
630 Cpat.wild (Type.new ())
631 in
632 case Apat.node p of
633 Apat.App (c, p) =>
634 (case Env.lookupLongcon (E, c) of
635 NONE => dontCare ()
636 | SOME (con, s) =>
637 let
638 val {args, instance} = Scheme.instantiate s
639 val args = args ()
640 val p = loop p
641 val (argType, resultType) =
642 case Type.deArrowOpt instance of
643 SOME types => types
644 | NONE =>
645 let
646 val types =
647 (Type.new (), Type.new ())
648 val _ =
649 unify
650 (instance, Type.arrow types,
651 fn _ =>
652 (region,
653 str "constant constructor applied to argument in pattern",
654 Layout.empty))
655 in
656 types
657 end
658 val _ =
659 unify
660 (Cpat.ty p, argType, fn (l, l') =>
661 (region,
662 str "constructor applied to incorrect argument in pattern",
663 align [seq [str "expects: ", l'],
664 seq [str "but got: ", l]]))
665 in
666 Cpat.make (Cpat.Con {arg = SOME p,
667 con = con,
668 targs = args},
669 resultType)
670 end)
671 | Apat.Const c =>
672 elabConst
673 (c,
674 {layoutPrettyType = #1 o layoutPrettyType},
675 fn (resolve, ty) => Cpat.make (Cpat.Const resolve, ty),
676 {false = Cpat.falsee,
677 true = Cpat.truee})
678 | Apat.Constraint (p, t) =>
679 let
680 val p' = loop p
681 val _ =
682 unifyPatternConstraint
683 (Cpat.ty p', elabType t)
684 in
685 p'
686 end
687 | Apat.FlatApp items =>
688 loop (Parse.parsePat
689 (items, E, fn () => ctxt ()))
690 | Apat.Layered {var = x, constraint, pat, ...} =>
691 let
692 val t =
693 case constraint of
694 NONE => Type.new ()
695 | SOME t => elabType t
696 val xc = Avid.toCon (Avid.fromVar x)
697 val x =
698 case Env.peekLongcon (E, Ast.Longcon.short xc) of
699 NONE => bindToType (x, t)
700 | SOME _ =>
701 let
702 val _ =
703 Control.error
704 (region,
705 seq [str "constructor cannot be redefined by as: ",
706 Avar.layout x],
707 ctxt ())
708 in
709 Var.fromAst x
710 end
711 val pat' = loop pat
712 val _ =
713 unifyPatternConstraint (Cpat.ty pat', t)
714 in
715 Cpat.make (Cpat.Layered (x, pat'), t)
716 end
717 | Apat.List ps =>
718 let
719 val ps' = Vector.map (ps, loop)
720 in
721 Cpat.make (Cpat.List ps',
722 unifyList
723 (Vector.map2 (ps, ps', fn (p, p') =>
724 (Cpat.ty p', Apat.region p)),
725 unify))
726 end
727 | Apat.Or ps =>
728 let
729 val _ = check (Control.Elaborate.allowOrPats, "Or patterns", region)
730 val xtsOrig = !xts
731 val n = Vector.length ps
732 val ps =
733 Vector.map
734 (ps, fn p =>
735 let
736 val _ = xts := []
737 val p' = loop p
738 in
739 (p, p', !xts)
740 end)
741 val ps' = Vector.map (ps, fn (_, p', _) => p')
742
743 val xtsPats =
744 Vector.fold
745 (ps, [], fn ((p, _, xtsPat), xtsPats) =>
746 List.fold
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) =>
751 let
752 val _ = List.push (l, x)
753 val _ =
754 unify
755 (t', t, fn (l', l) =>
756 (Avar.region x,
757 seq [str "or-pattern with variable of different type: ",
758 Avar.layout x],
759 align [seq [str "variable: ", l],
760 seq [str "previous: ", l'],
761 seq [str "in: ", approximate (Apat.layout p)]]))
762 in
763 xtsPats
764 end))
765 val _ =
766 List.foreach
767 (xtsPats, fn (x, _, _, l) =>
768 if List.length (!l) <> n
769 then let
770 val _ =
771 Control.error
772 (Apat.region p,
773 seq [str "variable does not occur in all patterns of or-pattern: ",
774 Avar.layout x],
775 ctxt ())
776 in
777 ()
778 end
779 else ())
780 val t = Type.new ()
781 val _ =
782 Vector.foreach
783 (ps, fn (p, p', _) =>
784 unify
785 (t, Cpat.ty p', fn (l, l') =>
786 (Apat.region p,
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)]])))
791 val xtsMerge =
792 List.fold
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
796 | SOME _ =>
797 let
798 val _ =
799 List.foreach
800 (List.rev (!l), fn x =>
801 Control.error
802 (Avar.region x,
803 seq [str "duplicate variable in pattern: ", Avar.layout x],
804 ctxtTop ()))
805 in
806 (x, x', t)::xtsMerge
807 end)
808 val _ = xts := xtsMerge
809 in
810 Cpat.make (Cpat.Or ps', t)
811 end
812 | Apat.Paren p => loop p
813 | Apat.Record {flexible, items} =>
814 (* rules 36, 38, 39 and Appendix A, p.57 *)
815 let
816 val (fs, ps) =
817 Vector.unzip
818 (Vector.map
819 (items,
820 fn (f, _, i) =>
821 (f,
822 case i of
823 Apat.Item.Field p => p
824 | Apat.Item.Vid (vid, tyo, po) =>
825 let
826 val p =
827 case po of
828 NONE =>
829 Apat.longvid (Longvid.short vid)
830 | SOME p =>
831 Apat.layered
832 {fixop = Fixop.None,
833 var = Ast.Vid.toVar vid,
834 constraint = NONE,
835 pat = p}
836 in
837 case tyo of
838 NONE => p
839 | SOME ty => Apat.constraint (p, ty)
840 end)))
841 val ps = Vector.map (ps, loop)
842 val r = SortedRecord.zip (fs, Vector.map (ps, Cpat.ty))
843 val ty =
844 if flexible
845 then
846 let
847 val (t, isResolved) = Type.flexRecord r
848 fun resolve () =
849 if isResolved ()
850 then ()
851 else
852 Control.error
853 (region,
854 str "unresolved ... in record pattern",
855 ctxt ())
856 val _ = List.push (unresolvedFlexRecordChecks, resolve)
857 in
858 t
859 end
860 else
861 Type.record r
862 in
863 Cpat.make
864 (Cpat.Record (Record.fromVector (Vector.zip (fs, ps))),
865 ty)
866 end
867 | Apat.Tuple ps =>
868 Cpat.tuple (Vector.map (ps, loop))
869 | Apat.Var {name, ...} =>
870 let
871 val (strids, x) = Ast.Longvid.split name
872 fun var () =
873 let
874 val (x, t) = bind (Ast.Vid.toVar x)
875 in
876 Cpat.make (Cpat.Var x, t)
877 end
878 in
879 case Env.peekLongcon (E, Ast.Longvid.toLongcon name) of
880 NONE =>
881 if List.isEmpty strids
882 then var ()
883 else
884 let
885 val _ =
886 Control.error
887 (region,
888 seq [str "undefined constructor: ",
889 Ast.Longvid.layout name],
890 empty)
891 in
892 Cpat.make (Cpat.Wild, Type.new ())
893 end
894 | SOME (c, s) =>
895 if List.isEmpty strids andalso isRvb
896 then var ()
897 else let
898 val {args, instance} =
899 Scheme.instantiate s
900 in
901 if Type.isArrow instance
902 then
903 (Control.error
904 (region,
905 seq [str "constructor used without argument in pattern: ",
906 Ast.Longvid.layout name],
907 empty)
908 ; dontCare ())
909 else
910 Cpat.make
911 (Cpat.Con {arg = NONE,
912 con = c,
913 targs = args ()},
914 instance)
915 end
916 end
917 | Apat.Vector ps =>
918 let
919 val _ = check (ElabControl.allowVectorPats, "Vector patterns", Apat.region p)
920 val ps' = Vector.map (ps, loop)
921 in
922 Cpat.make (Cpat.Vector ps',
923 unifyVector
924 (Vector.map2 (ps, ps', fn (p, p') =>
925 (Cpat.ty p', Apat.region p)),
926 unify))
927 end
928 | Apat.Wild =>
929 Cpat.make (Cpat.Wild, Type.new ())
930 end) arg
931 val p' = loop p
932 val xts = Vector.fromList (!xts)
933 val _ =
934 Vector.foreach
935 (xts, fn (x, _, _) =>
936 case (List.peekMap
937 (!others, fn (p, v) =>
938 if Vector.exists (v, fn (y, _, _) =>
939 Avar.equals (x, y))
940 then SOME p
941 else NONE)) of
942 NONE => ()
943 | SOME p' =>
944 Control.error
945 (Avar.region x,
946 seq [str "variable bound in multiple patterns: ",
947 Avar.layout x],
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))
953 val _ =
954 if bindInEnv
955 then Vector.foreach
956 (xts, fn (x, x', t) =>
957 Env.extendVar (E, x, x', Scheme.fromType t,
958 {isRebind = false}))
959 else ()
960 in
961 (p', xts)
962 end
963 end
964
965 (*---------------------------------------------------*)
966 (* Declarations *)
967 (*---------------------------------------------------*)
968
969 structure Nest =
970 struct
971 type t = string list
972
973 val layout = List.layout String.layout
974 end
975
976 val elabDecInfo = Trace.info "ElaborateCore.elabDec"
977 val elabExpInfo = Trace.info "ElaborateCore.elabExp"
978
979 structure Type =
980 struct
981 open Type
982
983 val nullary: (string * CType.t * Tycon.t) list =
984 let
985 fun sized (tycon: Bits.t -> Tycon.t, ctypes) =
986 List.map
987 (ctypes, fn cty =>
988 let
989 val c = tycon (Bytes.toBits (CType.size cty))
990 val s = Tycon.toString c
991 val s =
992 CharVector.tabulate
993 (String.size s, fn i =>
994 let
995 val c = String.sub (s, i)
996 in
997 if i = 0 then Char.toUpper c else c
998 end)
999 in
1000 (s, cty, c)
1001 end)
1002 in
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,
1009 let
1010 open CType
1011 in
1012 [Word8, Word16, Word32]
1013 end)
1014 @ sized (Tycon.int o IntSize.fromBits,
1015 let
1016 open CType
1017 in
1018 [Int8, Int16, Int32, Int64]
1019 end)
1020 @ sized (Tycon.word o WordSize.fromBits,
1021 let
1022 open CType
1023 in
1024 [Word8, Word16, Word32, Word64]
1025 end)
1026 end
1027
1028 val nullary =
1029 List.map (nullary, fn (name, ctype, tycon) =>
1030 {ctype = ctype, name = name, tycon = tycon})
1031
1032 val unary: Tycon.t list =
1033 [Tycon.array, Tycon.reff, Tycon.vector]
1034
1035 fun toNullaryCType (t: t): {ctype: CType.t, name: string} option =
1036 case deConOpt t of
1037 NONE => NONE
1038 | SOME (c, _) =>
1039 Option.map
1040 (List.peek (nullary, fn {tycon = c', ...} =>
1041 Tycon.equals (c, c')),
1042 fn {ctype, name, ...} => {ctype = ctype, name = name})
1043
1044 and toUnaryCType (t: t): {ctype: CType.t, name: string} option =
1045 case deConOpt t of
1046 NONE => NONE
1047 | SOME (c, ts) =>
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"}
1052 else NONE
1053
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}
1058
1059 val toCType =
1060 Trace.trace
1061 ("ElaborateCore.Type.toCType",
1062 layout,
1063 Option.layout (fn {ctype, name} =>
1064 Layout.record
1065 [("ctype", CType.layout ctype),
1066 ("name", String.layout name)]))
1067 toCType
1068
1069 type z = {ctype: CType.t, name: string, ty: t}
1070
1071 fun toCBaseType (ty: t): z option =
1072 case toCType ty of
1073 NONE => NONE
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
1078 NONE =>
1079 (case toCBaseType ty of
1080 NONE => NONE
1081 | SOME z => SOME (Vector.new1 z))
1082 | SOME tys =>
1083 Exn.withEscape
1084 (fn esc =>
1085 (SOME o Vector.map)
1086 (tys, fn ty =>
1087 case toCBaseType ty of
1088 NONE => esc NONE
1089 | SOME z => z))
1090 fun toCRetType (ty: t): z option option =
1091 case toCBaseType ty of
1092 NONE => if Type.isUnit ty
1093 then SOME NONE
1094 else NONE
1095 | SOME z => SOME (SOME z)
1096 fun toCFunType (ty: t): (z vector * z option) option =
1097 case deArrowOpt ty of
1098 NONE => NONE
1099 | SOME (arg, ret) =>
1100 (case toCArgType arg of
1101 NONE => NONE
1102 | SOME arg =>
1103 (case toCRetType ret of
1104 NONE => NONE
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}
1110 end
1111 else NONE
1112 end
1113
1114 val isIEAttributeConvention =
1115 fn ImportExportAttribute.Cdecl => true
1116 | ImportExportAttribute.Stdcall => true
1117 | _ => false
1118
1119 fun parseIEAttributesConvention (attributes: ImportExportAttribute.t list)
1120 : Convention.t option =
1121 case attributes of
1122 [] => SOME Convention.Cdecl
1123 | [a] =>
1124 (case a of
1125 ImportExportAttribute.Cdecl => SOME Convention.Cdecl
1126 | ImportExportAttribute.Stdcall =>
1127 if let
1128 open Control
1129 in
1130 case !Target.os of
1131 Target.Cygwin => true
1132 | Target.MinGW => true
1133 | _ => false
1134 end
1135 then SOME Convention.Stdcall
1136 else SOME Convention.Cdecl
1137 | _ => NONE)
1138 | _ => NONE
1139
1140 val isIEAttributeKind =
1141 fn ImportExportAttribute.Impure => true
1142 | ImportExportAttribute.Pure => true
1143 | ImportExportAttribute.Runtime => true
1144 | ImportExportAttribute.Reentrant => true
1145 | _ => false
1146
1147 fun parseIEAttributesKind (attributes: ImportExportAttribute.t list)
1148 : CKind.t option =
1149 case attributes of
1150 [] => SOME CKind.Impure
1151 | [a] =>
1152 (case a of
1153 ImportExportAttribute.Impure => SOME CKind.impure
1154 | ImportExportAttribute.Pure => SOME CKind.pure
1155 | ImportExportAttribute.Runtime => SOME CKind.runtimeDefault
1156 | ImportExportAttribute.Reentrant => SOME CKind.reentrant
1157 | _ => NONE)
1158 | _ => NONE
1159
1160 val isIEAttributeSymbolScope =
1161 fn ImportExportAttribute.External => true
1162 | ImportExportAttribute.Private => true
1163 | ImportExportAttribute.Public => true
1164 | _ => false
1165
1166 fun parseIEAttributesSymbolScope (attributes: ImportExportAttribute.t list,
1167 defScope : SymbolScope.t)
1168 : SymbolScope.t option =
1169 case attributes of
1170 [] => SOME defScope
1171 | [a] => (case a of
1172 ImportExportAttribute.External => SOME SymbolScope.External
1173 | ImportExportAttribute.Private => SOME SymbolScope.Private
1174 | ImportExportAttribute.Public => SOME SymbolScope.Public
1175 | _ => NONE)
1176 | _ => NONE
1177
1178 fun scopeCheck {name, symbolScope, region} =
1179 let
1180 fun warn l =
1181 Control.warning (region, seq (List.map (l, str)), empty)
1182 val oldScope =
1183 Ffi.checkScope {name = name, symbolScope = symbolScope}
1184 in
1185 if symbolScope = oldScope then () else
1186 warn [ "symbol '", name, "' redeclared as ",
1187 SymbolScope.toString symbolScope,
1188 " (previously ",
1189 SymbolScope.toString oldScope,
1190 "). This may cause linker errors"]
1191 end
1192
1193 fun import {attributes: ImportExportAttribute.t list,
1194 elabedTy: Type.t,
1195 expandedTy: Type.t,
1196 name: string option,
1197 region: Region.t,
1198 layoutPrettyType: Type.t -> Layout.t}: Type.t Prim.t =
1199 let
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 () =
1205 Control.error
1206 (region,
1207 str "invalid type for _import",
1208 layoutPrettyType elabedTy)
1209 in
1210 case Type.toCFunType expandedTy of
1211 NONE =>
1212 let
1213 val () = invalidType ()
1214 in
1215 Prim.bogus
1216 end
1217 | SOME (args, result) =>
1218 let
1219 datatype z = datatype CFunction.Target.t
1220 val convention =
1221 List.keepAll (attributes, isIEAttributeConvention)
1222 val convention =
1223 case parseIEAttributesConvention convention of
1224 NONE => (invalidAttributes ()
1225 ; Convention.Cdecl)
1226 | SOME c => c
1227 val kind =
1228 List.keepAll (attributes, isIEAttributeKind)
1229 val kind =
1230 case parseIEAttributesKind kind of
1231 NONE => (invalidAttributes ()
1232 ; CKind.Impure)
1233 | SOME k => k
1234 val symbolScope =
1235 List.keepAll (attributes, isIEAttributeSymbolScope)
1236 val symbolScope =
1237 case name of
1238 NONE =>
1239 (if List.isEmpty symbolScope
1240 then ()
1241 else invalidAttributes ()
1242 ; SymbolScope.External)
1243 | SOME name =>
1244 let
1245 val symbolScope =
1246 case parseIEAttributesSymbolScope
1247 (symbolScope, SymbolScope.External) of
1248 NONE => (invalidAttributes ()
1249 ; SymbolScope.External)
1250 | SOME s => s
1251 val () = scopeCheck {name = name,
1252 symbolScope = symbolScope,
1253 region = region}
1254 in
1255 symbolScope
1256 end
1257 val addrTy = Type.cpointer
1258 val func =
1259 CFunction.T {args = let
1260 val args = Vector.map (args, #ty)
1261 in
1262 if isSome name
1263 then args
1264 else Vector.concat
1265 [Vector.new1 addrTy, args]
1266 end,
1267 convention = convention,
1268 kind = kind,
1269 prototype = (Vector.map (args, #ctype),
1270 Option.map (result, #ctype)),
1271 return = (case result of
1272 NONE => Type.unit
1273 | SOME {ty, ...} => ty),
1274 symbolScope = symbolScope,
1275 target = (case name of
1276 NONE => Indirect
1277 | SOME name => Direct name)}
1278 in
1279 Prim.ffi func
1280 end
1281 end
1282
1283 fun primApp {args, prim, result: Type.t} =
1284 let
1285 val targs = Prim.extractTargs (prim,
1286 {args = Vector.map (args, Cexp.ty),
1287 result = result,
1288 typeOps = {deArray = Type.deArray,
1289 deArrow = Type.deArrow,
1290 deRef = Type.deRef,
1291 deVector = Type.deVector,
1292 deWeak = Type.deWeak}})
1293 in
1294 Cexp.make (Cexp.PrimApp {args = args,
1295 prim = prim,
1296 targs = targs},
1297 result)
1298 end
1299
1300 local
1301 val zeroExpBool =
1302 Cexp.make (Cexp.Const
1303 (fn () => Const.word (WordX.zero WordSize.bool)),
1304 Type.word WordSize.bool)
1305 val oneExpBool =
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 ()))
1313
1314 fun mkAddress {expandedPtrTy: Type.t,
1315 name: string,
1316 cty: CType.t option,
1317 symbolScope: SymbolScope.t }: Cexp.t =
1318 primApp {args = Vector.new0 (),
1319 prim = Prim.ffiSymbol {name = name,
1320 cty = cty,
1321 symbolScope = symbolScope},
1322 result = expandedPtrTy}
1323
1324 fun mkFetch {ctypeCbTy, isBool,
1325 expandedCbTy,
1326 ptrExp: Cexp.t}: Cexp.t =
1327 let
1328 val fetchExp =
1329 primApp {args = Vector.new2 (ptrExp, zeroExpPtrdiff ()),
1330 prim = Prim.cpointerGet ctypeCbTy,
1331 result = if isBool
1332 then Type.word WordSize.bool
1333 else expandedCbTy}
1334 in
1335 if not isBool then fetchExp else
1336 Cexp.iff (primApp
1337 {args = Vector.new2 (fetchExp, zeroExpBool),
1338 prim = Prim.wordEqual WordSize.bool,
1339 result = expandedCbTy},
1340 Cexp.falsee,
1341 Cexp.truee)
1342 end
1343
1344 fun mkStore {ctypeCbTy, isBool,
1345 ptrExp: Cexp.t, valueExp: Cexp.t}: Cexp.t =
1346 let
1347 val valueExp =
1348 if not isBool then valueExp else
1349 Cexp.iff (valueExp, oneExpBool, zeroExpBool)
1350 in
1351 primApp {args = Vector.new3 (ptrExp, zeroExpPtrdiff (), valueExp),
1352 prim = Prim.cpointerSet ctypeCbTy,
1353 result = Type.unit}
1354 end
1355
1356 fun mkSymbol {ctypeCbTy: CType.t,
1357 expandedCbTy: Type.t,
1358 ptrExp: Cexp.t}: Cexp.t =
1359 let
1360 val isBool = Type.isBool expandedCbTy
1361 val getArg = Var.newNoname ()
1362 val setArg = Var.newNoname ()
1363 in
1364 (Cexp.tuple o Vector.new2)
1365 ((Cexp.lambda o Lambda.make)
1366 {arg = getArg,
1367 argType = Type.unit,
1368 body = mkFetch {ctypeCbTy = ctypeCbTy,
1369 isBool = isBool,
1370 expandedCbTy = expandedCbTy,
1371 ptrExp = ptrExp},
1372 mayInline = true},
1373 (Cexp.lambda o Lambda.make)
1374 {arg = setArg,
1375 argType = expandedCbTy,
1376 body = mkStore {ctypeCbTy = ctypeCbTy,
1377 isBool = isBool,
1378 ptrExp = ptrExp,
1379 valueExp = Cexp.var (setArg, expandedCbTy)},
1380 mayInline = true})
1381 end
1382
1383 val isSymbolAttributeAlloc =
1384 fn SymbolAttribute.Alloc => true
1385 | _ => false
1386
1387 fun parseSymbolAttributesAlloc (attributes: SymbolAttribute.t list)
1388 : bool option =
1389 case attributes of
1390 [] => SOME false
1391 | [a] => (case a of
1392 SymbolAttribute.Alloc => SOME true
1393 | _=> NONE)
1394 | _ => NONE
1395
1396 val isSymbolAttributeSymbolScope =
1397 fn SymbolAttribute.Private => true
1398 | SymbolAttribute.Public => true
1399 | SymbolAttribute.External => true
1400 | _ => false
1401
1402 fun parseSymbolAttributesSymbolScope (attributes: SymbolAttribute.t list,
1403 defScope: SymbolScope.t)
1404 : SymbolScope.t option =
1405 case attributes of
1406 [] => SOME defScope
1407 | [a] => (case a of
1408 SymbolAttribute.Private => SOME SymbolScope.Private
1409 | SymbolAttribute.Public => SOME SymbolScope.Public
1410 | SymbolAttribute.External => SOME SymbolScope.External
1411 | _=> NONE)
1412 | _ => NONE
1413 in
1414 fun address {attributes: SymbolAttribute.t list,
1415 elabedTy: Type.t,
1416 expandedTy: Type.t,
1417 name: string,
1418 region: Region.t,
1419 layoutPrettyType: Type.t -> Layout.t}: Cexp.t =
1420 let
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 () =
1426 Control.error
1427 (region, str "invalid type for _address",
1428 layoutPrettyType elabedTy)
1429 val () =
1430 case Type.toCPtrType expandedTy of
1431 NONE => (invalidType (); ())
1432 | SOME _ => ()
1433 val expandedPtrTy = expandedTy
1434 val () =
1435 case List.keepAll (attributes, isSymbolAttributeAlloc) of
1436 [] => ()
1437 | _ => invalidAttributes ()
1438 val symbolScope =
1439 List.keepAll (attributes, isSymbolAttributeSymbolScope)
1440 val symbolScope =
1441 case parseSymbolAttributesSymbolScope
1442 (symbolScope, SymbolScope.External) of
1443 NONE => (invalidAttributes ()
1444 ; SymbolScope.External)
1445 | SOME s => s
1446 val () = scopeCheck {name = name,
1447 symbolScope = symbolScope,
1448 region = region}
1449 val addrExp =
1450 mkAddress {expandedPtrTy = expandedPtrTy,
1451 name = name,
1452 symbolScope = symbolScope,
1453 cty = NONE}
1454 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
1455 in
1456 wrap (addrExp, elabedTy)
1457 end
1458
1459 fun symbolDirect {attributes: SymbolAttribute.t list,
1460 elabedTy: Type.t,
1461 expandedTy: Type.t,
1462 name: string,
1463 region: Region.t,
1464 layoutPrettyType: Type.t -> Layout.t}: Cexp.t =
1465 let
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 () =
1471 Control.error
1472 (region, str "invalid type for _symbol",
1473 layoutPrettyType elabedTy)
1474 val expandedCbTy =
1475 Exn.withEscape
1476 (fn escape =>
1477 let
1478 val invalidType = fn () =>
1479 (invalidType ()
1480 ; ignore (escape Type.word8)
1481 ; Error.bug "ElaborateCore.symbolDirect.escape")
1482 in
1483 case Type.deTupleOpt expandedTy of
1484 NONE => invalidType ()
1485 | SOME tys =>
1486 if Vector.length tys <> 2
1487 then invalidType ()
1488 else let
1489 fun doit ty =
1490 case Type.deArrowOpt ty of
1491 NONE => invalidType ()
1492 | SOME tys => tys
1493 val (getArgTy, getResTy) =
1494 doit (Vector.first tys)
1495 val (setArgTy, setResTy) =
1496 doit (Vector.sub (tys, 1))
1497 val () =
1498 if Type.isUnit getArgTy
1499 then ()
1500 else invalidType ()
1501 val () =
1502 if Type.isUnit setResTy
1503 then ()
1504 else invalidType ()
1505 val () =
1506 if Type.canUnify (getResTy, setArgTy)
1507 then ()
1508 else invalidType ()
1509 in
1510 getResTy
1511 end
1512 end)
1513 val ctypeCbTy =
1514 case Type.toCBaseType expandedCbTy of
1515 NONE => (invalidType ()
1516 ; CType.word (WordSize.word8, {signed = false}))
1517 | SOME {ctype, ...} => ctype
1518 val alloc =
1519 List.keepAll (attributes, isSymbolAttributeAlloc)
1520 val alloc =
1521 case parseSymbolAttributesAlloc alloc of
1522 NONE => (invalidAttributes ()
1523 ; false)
1524 | SOME a => a
1525 val defScope =
1526 if alloc then SymbolScope.Public else SymbolScope.External
1527 val symbolScope =
1528 List.keepAll (attributes, isSymbolAttributeSymbolScope)
1529 val symbolScope =
1530 case parseSymbolAttributesSymbolScope
1531 (symbolScope, defScope) of
1532 NONE => (invalidAttributes ()
1533 ; defScope)
1534 | SOME s => s
1535 val () =
1536 if alloc andalso symbolScope = SymbolScope.External
1537 then invalidAttributes () else ()
1538 val () = scopeCheck {name = name,
1539 symbolScope = symbolScope,
1540 region = region}
1541 val () =
1542 if not alloc then () else
1543 Ffi.addSymbol {name = name,
1544 ty = ctypeCbTy,
1545 symbolScope = symbolScope}
1546 val addrExp =
1547 mkAddress {expandedPtrTy = Type.cpointer,
1548 name = name,
1549 cty = SOME ctypeCbTy,
1550 symbolScope = symbolScope}
1551 val symExp =
1552 mkSymbol {ctypeCbTy = ctypeCbTy,
1553 expandedCbTy = expandedCbTy,
1554 ptrExp = addrExp}
1555 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
1556 in
1557 wrap (symExp, elabedTy)
1558 end
1559
1560 fun symbolIndirect {elabedTy: Type.t,
1561 expandedTy: Type.t,
1562 region: Region.t,
1563 layoutPrettyType: Type.t -> Layout.t}: Cexp.t =
1564 let
1565 fun invalidType () =
1566 Control.error
1567 (region, str "invalid type for _symbol",
1568 layoutPrettyType elabedTy)
1569 val (expandedPtrTy, expandedCbTy) =
1570 Exn.withEscape
1571 (fn escape =>
1572 let
1573 val invalidType = fn () =>
1574 (invalidType ()
1575 ; ignore (escape (Type.cpointer, Type.word8))
1576 ; Error.bug "ElaborateCore.symbolIndirect.escape")
1577 in
1578 case Type.deArrowOpt expandedTy of
1579 NONE => invalidType ()
1580 | SOME (ptrTy, symTy) =>
1581 (case Type.deTupleOpt symTy of
1582 NONE => invalidType ()
1583 | SOME tys =>
1584 if Vector.length tys <> 2
1585 then invalidType ()
1586 else let
1587 fun doit ty =
1588 case Type.deArrowOpt ty of
1589 NONE => invalidType ()
1590 | SOME tys => tys
1591 val (getArgTy, getResTy) =
1592 doit (Vector.sub (tys, 0))
1593 val (setArgTy, setResTy) =
1594 doit (Vector.sub (tys, 1))
1595 val () =
1596 if Type.isUnit getArgTy
1597 then ()
1598 else invalidType ()
1599 val () =
1600 if Type.isUnit setResTy
1601 then ()
1602 else invalidType ()
1603 val () =
1604 if Type.canUnify (getResTy, setArgTy)
1605 then ()
1606 else invalidType ()
1607 in
1608 (ptrTy, getResTy)
1609 end)
1610 end)
1611 val ctypeCbTy =
1612 case Type.toCBaseType expandedCbTy of
1613 NONE => (invalidType (); CType.word (WordSize.word8, {signed = false}))
1614 | SOME {ctype, ...} => ctype
1615 val () =
1616 case Type.toCPtrType expandedPtrTy of
1617 NONE => (invalidType (); ())
1618 | SOME _ => ()
1619 val ptrArg = Var.newNoname ()
1620 val ptrExp = Cexp.var (ptrArg, expandedPtrTy)
1621 val symExp =
1622 mkSymbol {ctypeCbTy = ctypeCbTy,
1623 expandedCbTy = expandedCbTy,
1624 ptrExp = ptrExp}
1625 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
1626 in
1627 wrap ((Cexp.lambda o Lambda.make)
1628 {arg = ptrArg,
1629 argType = expandedPtrTy,
1630 body = symExp,
1631 mayInline = true},
1632 elabedTy)
1633 end
1634 end
1635
1636 fun export {attributes: ImportExportAttribute.t list,
1637 elabedTy: Type.t,
1638 expandedTy: Type.t,
1639 name: string,
1640 region: Region.t,
1641 layoutPrettyType: Type.t -> Layout.t}: Aexp.t =
1642 let
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 () =
1648 Control.error
1649 (region,
1650 str "invalid type for _export",
1651 layoutPrettyType elabedTy)
1652 val convention =
1653 List.keepAll (attributes, isIEAttributeConvention)
1654 val convention =
1655 case parseIEAttributesConvention convention of
1656 NONE => (invalidAttributes ()
1657 ; Convention.Cdecl)
1658 | SOME c => c
1659 val symbolScope =
1660 List.keepAll (attributes, isIEAttributeSymbolScope)
1661 val symbolScope =
1662 case parseIEAttributesSymbolScope
1663 (symbolScope, SymbolScope.Public) of
1664 NONE => (invalidAttributes ()
1665 ; SymbolScope.Public)
1666 | SOME SymbolScope.External =>
1667 (invalidAttributes ()
1668 ; SymbolScope.Public)
1669 | SOME s => s
1670 val () = scopeCheck {name = name,
1671 symbolScope = symbolScope,
1672 region = region}
1673 val (exportId, args, res) =
1674 case Type.toCFunType expandedTy of
1675 NONE =>
1676 (invalidType ()
1677 ; (0, Vector.new0 (), NONE))
1678 | SOME (args, result) =>
1679 let
1680 val id =
1681 Ffi.addExport {args = Vector.map (args, #ctype),
1682 convention = convention,
1683 name = name,
1684 res = Option.map (result, #ctype),
1685 symbolScope = symbolScope}
1686 in
1687 (id, args, result)
1688 end
1689 open Ast
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)
1697 in
1698 Exp.fnn
1699 (Vector.new1
1700 (Pat.var f,
1701 Exp.app
1702 (id "register",
1703 Exp.tuple
1704 (Vector.new2
1705 (int exportId,
1706 Exp.fnn
1707 (Vector.new1
1708 (Pat.var p,
1709 let
1710 val (args, decs) =
1711 Vector.unzip
1712 (Vector.mapi
1713 (args, fn (i, {name, ...}) =>
1714 let
1715 val x =
1716 Var.fromSymbol
1717 (Symbol.fromString (concat ["x", Int.toString i]),
1718 region)
1719 val dec =
1720 Dec.vall
1721 (Vector.new0 (),
1722 x,
1723 Exp.app
1724 (id (concat ["get", name]),
1725 (Exp.tuple o Vector.new2)
1726 (Exp.var p, int (i + 1))))
1727 in
1728 (x, dec)
1729 end))
1730 val resVar = Var.fromSymbol (Symbol.fromString "res", region)
1731 fun newVar () = Var.fromSymbol (Symbol.fromString "none", region)
1732 in
1733 Exp.lett
1734 (Vector.concat
1735 [decs,
1736 Vector.map
1737 (Vector.new2
1738 ((resVar, Exp.app (Exp.var f,
1739 Exp.tuple (Vector.map (args, Exp.var)))),
1740 (newVar (),
1741 (case res of
1742 NONE => Exp.constraint (Exp.var resVar, Type.unit)
1743 | SOME {name, ...} =>
1744 Exp.app
1745 (id (concat ["set", name]),
1746 (Exp.tuple o Vector.new3)
1747 (Exp.var p,
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 ()),
1752 region)
1753 end)))))))
1754 end
1755
1756 val export =
1757 Trace.trace
1758 ("ElaborateCore.export",
1759 fn {name, ...} => String.layout name,
1760 Aexp.layout)
1761 export
1762
1763 structure Aexp =
1764 struct
1765 open Aexp
1766
1767 local
1768 val x = Avar.fromSymbol (Symbol.fromString "#", Region.bogus)
1769 val xField = Apat.Item.Field (Apat.var x)
1770 val xVar = var x
1771 in
1772 fun selector (f: Field.t, r: Region.t): t =
1773 fnn (Vector.new1
1774 (Apat.makeRegion
1775 (Apat.Record {flexible = true,
1776 items = Vector.new1 (f, Region.bogus, xField)},
1777 r),
1778 xVar))
1779 end
1780 end
1781
1782 structure Con =
1783 struct
1784 open Con
1785
1786 val fromAst = newString o Ast.Con.toString
1787 end
1788
1789 structure Cexp =
1790 struct
1791 open Cexp
1792
1793 fun enterLeave (e: t, doit: bool, si): t =
1794 if not doit
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
1798 * bad.
1799 *)
1800 orelse Env.amInsideFunctor ()
1801 (* Don't create the source info if we're profiling some IL. *)
1802 orelse !Control.profileIL <> Control.ProfileSource
1803 then e
1804 else make (EnterLeave (e, si ()), ty e)
1805 end
1806
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.
1810 *)
1811 val {get = recursiveTargs: Var.t -> (unit -> Type.t vector) option ref,
1812 ...} =
1813 Property.get (Var.plist, Property.initFun (fn _ => ref NONE))
1814
1815 fun elaborateDec (d, {env = E, nest}) =
1816 let
1817 val profileBody =
1818 let
1819 open Control
1820 in
1821 !profile <> ProfileNone
1822 end
1823 fun recursiveFun () =
1824 let
1825 val boundRef: (unit -> Tyvar.t vector) option ref = ref NONE
1826 val targs =
1827 Promise.lazy
1828 (fn () =>
1829 case !boundRef of
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
1835 in
1836 {markFunc = markFunc,
1837 setBound = setBound,
1838 unmarkFunc = unmarkFunc}
1839 end
1840 fun elabType (t: Atype.t, {bogusAsUnknown}): Type.t =
1841 elaborateType (t, E, {bogusAsUnknown = bogusAsUnknown})
1842 fun elabTypBind (typBind: TypBind.t) =
1843 let
1844 val TypBind.T types = TypBind.node typBind
1845 val types =
1846 Vector.map
1847 (types, fn {def, tycon, tyvars} =>
1848 TyvarEnv.scope
1849 (tyvars, fn tyvars =>
1850 {scheme = Scheme.make {canGeneralize = true,
1851 ty = elabType (def, {bogusAsUnknown = false}),
1852 tyvars = tyvars},
1853 tycon = tycon}))
1854 val () =
1855 Vector.foreach
1856 (types, fn {scheme, tycon} =>
1857 Env.extendTycon
1858 (E, tycon, TypeStr.def scheme,
1859 {forceUsed = false,
1860 isRebind = false}))
1861 (* Rebuild type to propagate tycon equality
1862 * when 'withtype' components of 'datatype' decl. *)
1863 fun rebind () =
1864 Vector.foreach
1865 (types, fn {scheme, tycon} =>
1866 let
1867 val (tyvars, ty) = Scheme.dest scheme
1868 val ty = Type.copy ty
1869 val scheme =
1870 Scheme.make {canGeneralize = true,
1871 tyvars = tyvars,
1872 ty = ty}
1873 in
1874 Env.extendTycon
1875 (E, tycon, TypeStr.def scheme,
1876 {forceUsed = false,
1877 isRebind = true})
1878 end)
1879 in
1880 rebind
1881 end
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 *)
1885 let
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.
1889 *)
1890 val datatypes =
1891 Vector.map
1892 (datatypes, fn {cons, tycon = name, tyvars} =>
1893 let
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
1899 val tycon =
1900 Tycon.make {admitsEquality = AdmitsEquality.Sometimes,
1901 kind = k,
1902 name = n,
1903 prettyDefault = pd,
1904 region = r}
1905 val _ = Env.extendTycon (E, name, TypeStr.tycon tycon,
1906 {forceUsed = true,
1907 isRebind = false})
1908 in
1909 {arity = arity,
1910 cons = cons,
1911 name = name,
1912 tycon = tycon,
1913 tyvars = tyvars}
1914 end)
1915 val rebindWithtypes = elabTypBind withtypes
1916 val datatypes =
1917 Vector.map
1918 (datatypes, fn {arity, cons, name, tycon, tyvars} =>
1919 let
1920 val cons =
1921 Vector.map
1922 (cons, fn (name, arg) =>
1923 TyvarEnv.scope
1924 (tyvars, fn tyvars =>
1925 {arg = Option.map (arg, fn t => elabType (t, {bogusAsUnknown = false})),
1926 con = Con.fromAst name,
1927 name = name,
1928 tyvars = tyvars}))
1929 in
1930 {arity = arity,
1931 cons = cons,
1932 name = name,
1933 tycon = tycon}
1934 end)
1935 (* Maximize equality *)
1936 val change = ref false
1937 fun loop datatypes =
1938 let
1939 val datatypes =
1940 Vector.map
1941 (datatypes, fn {arity, cons, name, tycon} =>
1942 let
1943 val isEquality = ref true
1944 val cons =
1945 Vector.map
1946 (cons, fn {arg, con, name, tyvars} =>
1947 let
1948 val arg =
1949 Option.map
1950 (arg, fn arg =>
1951 let
1952 (* Rebuild type to propagate tycon equality. *)
1953 val arg = Type.copy arg
1954 val argScheme =
1955 Scheme.make {canGeneralize = true,
1956 ty = arg,
1957 tyvars = tyvars}
1958 val () =
1959 if Scheme.admitsEquality argScheme
1960 then ()
1961 else isEquality := false
1962 in
1963 arg
1964 end)
1965 in
1966 {arg = arg,
1967 con = con,
1968 name = name,
1969 tyvars = tyvars}
1970 end)
1971 datatype z = datatype AdmitsEquality.t
1972 val () =
1973 case Tycon.admitsEquality tycon of
1974 Always =>
1975 Error.bug "ElaborateCore.elaborateDec.elabDatBind: Always"
1976 | Never => ()
1977 | Sometimes =>
1978 if !isEquality
1979 then ()
1980 else (Tycon.setAdmitsEquality (tycon, Never)
1981 ; change := true)
1982 in
1983 {arity = arity,
1984 cons = cons,
1985 name = name,
1986 tycon = tycon}
1987 end)
1988 in
1989 if !change
1990 then (change := false; loop datatypes)
1991 else datatypes
1992 end
1993 val datatypes = loop datatypes
1994 val (datatypes, strs) =
1995 (Vector.unzip o Vector.map)
1996 (datatypes, fn {arity, cons, name, tycon} =>
1997 let
1998 val tyvars' =
1999 Vector.tabulate (arity, fn _ => Tyvar.makeNoname {equality = false})
2000 val tyargs' =
2001 Vector.map (tyvars', Type.var)
2002 val (cons, cons') =
2003 (Vector.unzip o Vector.map)
2004 (cons, fn {arg, con, name, tyvars} =>
2005 let
2006 val res =
2007 Type.con (tycon, Vector.map (tyvars, Type.var))
2008 val (arg', ty) =
2009 case arg of
2010 NONE => (NONE, res)
2011 | SOME arg =>
2012 let
2013 val argScheme =
2014 Scheme.make {canGeneralize = true,
2015 ty = arg,
2016 tyvars = tyvars}
2017 val arg' = Scheme.apply (argScheme, tyargs')
2018 in
2019 (SOME arg',
2020 Type.arrow (arg, res))
2021 end
2022 val scheme =
2023 Scheme.make {canGeneralize = true,
2024 ty = ty,
2025 tyvars = tyvars}
2026 in
2027 ({con = con,
2028 name = name,
2029 scheme = scheme},
2030 {con = con,
2031 arg = arg'})
2032 end)
2033 val cons = Env.newCons (E, cons)
2034 val typeStr = TypeStr.data (tycon, cons)
2035 val () =
2036 Env.extendTycon
2037 (E, name, typeStr,
2038 {forceUsed = false,
2039 isRebind = true})
2040 in
2041 ({cons = cons',
2042 tycon = tycon,
2043 tyvars = tyvars'},
2044 {tycon = name,
2045 typeStr = typeStr})
2046 end)
2047 val () = rebindWithtypes ()
2048 in
2049 (Decs.single (Cdec.Datatype datatypes), strs)
2050 end
2051 fun elabDec arg : Decs.t =
2052 Trace.traceInfo
2053 (elabDecInfo,
2054 Layout.tuple3 (Ast.Dec.layout, Nest.layout, Bool.layout),
2055 Decs.layout, Trace.assertTrue)
2056 (fn (d, nest, isTop) =>
2057 let
2058 fun ctxt () = seq [str "in: ", approximate (Adec.layout d)]
2059 val region = Adec.region d
2060 fun generalizeError (var, lay, _) =
2061 Control.error
2062 (Avar.region var,
2063 seq [str "type of variable cannot be generalized in expansive declaration: ",
2064 Avar.layout var],
2065 align [seq [str "type: ", lay],
2066 ctxt ()])
2067 val () = Time.tick {region = region}
2068 fun checkSchemes (v: (Avar.t * Scheme.t) vector): unit =
2069 if isTop
2070 then Vector.foreach
2071 (v, fn (x, s) =>
2072 if not (Scheme.haveUnknowns s)
2073 then ()
2074 else List.push
2075 (undeterminedTypeChecks, fn () =>
2076 if not (Scheme.haveUnknowns s)
2077 then ()
2078 else let
2079 (* Technically, wrong scope for region;
2080 * but saving environment would probably
2081 * be expensive.
2082 *)
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
2090 val (lay, _) =
2091 Type.layoutPretty
2092 (t, {expandOpaque = false,
2093 layoutPrettyTycon = layoutPrettyTycon,
2094 layoutPrettyTyvar = layoutPrettyTyvar})
2095 in
2096 Control.warning
2097 (Avar.region x,
2098 seq [str "type of variable was not inferred and could not be generalized: ",
2099 Avar.layout x],
2100 align [seq [str "type: ", lay],
2101 ctxt ()])
2102 end))
2103 else ()
2104 fun checkConRedefine (vid, keyword, ctxt) =
2105 case Env.peekLongcon (E, Ast.Longcon.short (Avid.toCon vid)) of
2106 NONE => ()
2107 | SOME _ =>
2108 (case valrecConstr () of
2109 Control.Elaborate.DiagEIW.Error => Control.error
2110 | Control.Elaborate.DiagEIW.Ignore => (fn _ => ())
2111 | Control.Elaborate.DiagEIW.Warn => Control.warning)
2112 (Avid.region vid,
2113 seq [str "constructor redefined by ",
2114 str keyword,
2115 str ": ",
2116 Avid.layout vid],
2117 ctxt ())
2118 val elabDec = fn (d, isTop) => elabDec (d, nest, isTop)
2119 val decs =
2120 case Adec.node d of
2121 Adec.Abstype {datBind, body} => (* rule 19 and p.57 *)
2122 let
2123 val ((decs, strs), decs') =
2124 Env.localCore
2125 (E,
2126 fn () => elabDatBind (datBind, nest),
2127 fn z => (z, elabDec (body, isTop)))
2128 val () =
2129 Vector.foreach
2130 (strs, fn {tycon, typeStr} =>
2131 Env.extendTycon (E, tycon, TypeStr.abs typeStr,
2132 {forceUsed = true,
2133 isRebind = false}))
2134 in
2135 Decs.append (decs, decs')
2136 end
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 *)
2142 let
2143 val () =
2144 Option.app
2145 (Env.lookupLongtycon (E, rhs), fn s =>
2146 let
2147 val forceUsed =
2148 case TypeStr.node s of
2149 TypeStr.Datatype _ => true
2150 | _ => false
2151 val () =
2152 Env.extendTycon (E, lhs, s,
2153 {forceUsed = forceUsed,
2154 isRebind = false})
2155 in
2156 ()
2157 end)
2158 in
2159 Decs.empty
2160 end)
2161 | Adec.DoDec exp =>
2162 let
2163 val _ = check (ElabControl.allowDoDecls, "do declarations", Adec.region d)
2164 val {unify, ...} = DiagUtils.make E
2165 val exp' = elabExp (exp, nest, NONE)
2166 val _ =
2167 unify
2168 (Cexp.ty exp', Type.unit, fn (l1, _) =>
2169 (Aexp.region exp,
2170 str "do declaration expression not of type unit",
2171 align [seq [str "expression: ", l1],
2172 ctxt ()]))
2173 val vb = {ctxt = fn _ => empty,
2174 exp = exp',
2175 layPat = fn _ => empty,
2176 nest = nest,
2177 pat = Cpat.wild Type.unit,
2178 regionPat = Region.bogus}
2179 in
2180 Decs.single
2181 (Cdec.Val {matchDiags = matchDiagsFromNoMatch Cexp.Impossible,
2182 rvbs = Vector.new0 (),
2183 tyvars = Vector.new0,
2184 vbs = Vector.new1 vb})
2185 end
2186 | Adec.Exception ebs =>
2187 let
2188 val decs =
2189 Vector.fold
2190 (ebs, Decs.empty, fn ((exn, rhs), decs) =>
2191 let
2192 val decs =
2193 case EbRhs.node rhs of
2194 EbRhs.Def c =>
2195 (case Env.lookupLongexn (E, c) of
2196 NONE => decs
2197 | SOME (exn', scheme) =>
2198 let
2199 val _ = Env.extendExn (E, exn, exn', scheme)
2200 in
2201 decs
2202 end)
2203 | EbRhs.Gen arg =>
2204 let
2205 val exn' = Con.fromAst exn
2206 val (arg, ty) =
2207 case arg of
2208 NONE => (NONE, Type.exn)
2209 | SOME t =>
2210 let
2211 val t = elabType (t, {bogusAsUnknown = false})
2212 in
2213 (SOME t,
2214 Type.arrow (t, Type.exn))
2215 end
2216 val scheme = Scheme.fromType ty
2217 val _ = Env.extendExn (E, exn, exn', scheme)
2218 in
2219 Decs.add (decs,
2220 Cdec.Exception {arg = arg,
2221 con = exn'})
2222 end
2223 in
2224 decs
2225 end)
2226 in
2227 decs
2228 end
2229 | Adec.Fix {ops, fixity} =>
2230 (Vector.foreach (ops, fn op' =>
2231 Env.extendFix (E, op', fixity))
2232 ; Decs.empty)
2233 | Adec.Fun {tyvars = tyvars, fbs} =>
2234 let
2235 val close = TypeEnv.close {region = region}
2236 in
2237 TyvarEnv.scope
2238 (tyvars, fn tyvars' =>
2239 let
2240 val {layoutPrettyTycon, layoutPrettyTyvar, unify, ...} =
2241 DiagUtils.make E
2242 val {markFunc, setBound, unmarkFunc} = recursiveFun ()
2243 val fbs =
2244 Vector.map2
2245 (fbs, Adec.layoutFun {tyvars = tyvars, fbs = fbs}, fn (clauses, layFb) =>
2246 let
2247 val ctxtFb = fn () =>
2248 seq [str "in: ", approximate (layFb ())]
2249 val clauses =
2250 Vector.map
2251 (clauses, fn {body, pats, resultType} =>
2252 let
2253 fun layPats () =
2254 approximate (Apat.layoutFlatApp pats)
2255 fun layPatsPrefix () =
2256 approximatePrefix (Apat.layoutFlatApp pats)
2257 val regionPats =
2258 Region.append
2259 (Apat.region (Vector.first pats),
2260 Apat.region (Vector.last pats))
2261 val regionBody =
2262 Aexp.region body
2263 fun layClause () =
2264 approximate
2265 (seq [Apat.layoutFlatApp pats,
2266 case resultType of
2267 NONE => empty
2268 | SOME rt => seq [str ": ",
2269 Atype.layout rt],
2270 str " = ",
2271 Aexp.layout body])
2272 val regionClause =
2273 Region.append (regionPats, regionBody)
2274 val {args = pats, func} =
2275 Parse.parseClause (pats, E, ctxt)
2276 in
2277 {body = body,
2278 func = func,
2279 layClause = layClause,
2280 layPats = layPats,
2281 layPatsPrefix = layPatsPrefix,
2282 pats = pats,
2283 regionClause = regionClause,
2284 regionPats = regionPats,
2285 resultType = resultType}
2286 end)
2287 val regionFb =
2288 Region.append
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) =
2295 Control.error
2296 (reg,
2297 seq [str msg],
2298 align [seq [str desc, approximate (layN ())],
2299 seq [str "previous: ", approximate (lay0 ())],
2300 ctxtFb ()])
2301 val _ =
2302 Vector.foreach
2303 (clauses, fn {func = funcN, pats = patsN, layClause = layClauseN, regionPats = regionPatsN, ...} =>
2304 let
2305 val layFuncN = fn () => str (Avar.toString funcN)
2306 val _ =
2307 if Avar.equals (func, funcN)
2308 then ()
2309 else err (Avar.region funcN,
2310 "function clause with different name",
2311 "name: ", layFuncN, layFunc0)
2312 val _ =
2313 if Vector.length pats0 = Vector.length patsN
2314 then ()
2315 else err (regionPatsN,
2316 "function clause with different number of arguments",
2317 "clause: ", layClauseN, layClause0)
2318 in
2319 ()
2320 end)
2321 val numArgs =
2322 Vector.fold
2323 (clauses, ~1, fn (r, numArgs) =>
2324 Int.max (Vector.length (#pats r), numArgs))
2325 in
2326 {clauses = clauses,
2327 ctxtFb = ctxtFb,
2328 func = func,
2329 numArgs = numArgs,
2330 regionFb = regionFb}
2331 end)
2332 val _ =
2333 Vector.fold
2334 (fbs, [], fn ({func = f, ...}, ac) =>
2335 if List.exists (ac, fn f' => Avar.equals (f, f'))
2336 then
2337 (Control.error
2338 (Avar.region f,
2339 seq [str "duplicate function definition: ",
2340 Avar.layout f],
2341 ctxt ())
2342 ; ac)
2343 else f :: ac)
2344 val fbs =
2345 Vector.map
2346 (fbs, fn {clauses, ctxtFb, func, numArgs, regionFb} =>
2347 let
2348 val argTys = Vector.tabulate (numArgs, fn _ => Type.new ())
2349 val resTy = Type.new ()
2350 val clauses =
2351 Vector.map
2352 (clauses, fn {body, layPats, layPatsPrefix, pats, regionPats, resultType, ...} =>
2353 let
2354 val elaboratePat = elaboratePat ()
2355 val (pats, bindss) =
2356 (Vector.unzip o Vector.mapi)
2357 (pats, fn (i, pat) =>
2358 let
2359 val regionPat = Apat.region pat
2360 val (pat, binds) =
2361 elaboratePat
2362 (pat, E,
2363 {bind = false,
2364 isRvb = false})
2365 val _ =
2366 unify
2367 (Vector.sub (argTys, i), Cpat.ty pat, fn (l1, l2) =>
2368 (regionPat,
2369 str "function clause with argument of different type",
2370 align [seq [str "argument: ", l2],
2371 seq [str "previous: ", l1],
2372 ctxtFb ()]))
2373 in
2374 (pat, binds)
2375 end)
2376 val binds = Vector.concatV (Vector.rev bindss)
2377 val resultType =
2378 Option.map
2379 (resultType, fn resultType =>
2380 let
2381 val regionResultType = Atype.region resultType
2382 val resultType = elabType (resultType, {bogusAsUnknown = true})
2383 val _ =
2384 unify
2385 (resTy, resultType,
2386 fn (l1, l2) =>
2387 (regionResultType,
2388 str "function clause with result constraint of different type",
2389 align [seq [str "constraint: ", l2],
2390 seq [str "previous: ", l1],
2391 ctxtFb ()]))
2392 in
2393 (resultType, regionResultType)
2394 end)
2395 in
2396 {binds = binds,
2397 body = body,
2398 layPats = layPats,
2399 layPatsPrefix = layPatsPrefix,
2400 pats = pats,
2401 regionPats = regionPats,
2402 resultType = resultType}
2403 end)
2404 val funTy =
2405 let
2406 fun chk ty =
2407 if Type.isUnknown ty
2408 then Type.new ()
2409 else ty
2410 in
2411 if Vector.forall (argTys, Type.isUnknown)
2412 andalso Type.isUnknown resTy
2413 then Type.new ()
2414 else Vector.foldr (Vector.map (argTys, chk), chk resTy, Type.arrow)
2415 end
2416 val funcVid = Avid.fromVar func
2417 val _ =
2418 Avid.checkRedefineSpecial
2419 (funcVid,
2420 {allowIt = true,
2421 ctxt = ctxtFb,
2422 keyword = "fun"})
2423 val _ =
2424 checkConRedefine
2425 (funcVid, "fun", ctxtFb)
2426 val var = Var.fromAst func
2427 val _ =
2428 Env.extendVar
2429 (E, func, var,
2430 Scheme.fromType funTy,
2431 {isRebind = false})
2432 val _ =
2433 markFunc var
2434 in
2435 {argTys = argTys,
2436 clauses = clauses,
2437 ctxtFb = ctxtFb,
2438 func = func,
2439 funTy = funTy,
2440 regionFb = regionFb,
2441 resTy = resTy,
2442 var = var}
2443 end)
2444 val fbs =
2445 Vector.map
2446 (fbs, fn {argTys, clauses, ctxtFb, func, funTy, regionFb, resTy, var, ...} =>
2447 let
2448 val nest = Avar.toString func :: nest
2449 val resultTypeConstraint = Vector.exists (clauses, Option.isSome o #resultType)
2450 val rules =
2451 Vector.map
2452 (clauses, fn {binds, body, layPats, layPatsPrefix, pats, regionPats, resultType} =>
2453 let
2454 val regionBody = Aexp.region body
2455 val body =
2456 Env.scope
2457 (E, fn () =>
2458 (Vector.foreach
2459 (binds, fn (x, x', ty) =>
2460 Env.extendVar
2461 (E, x, x', Scheme.fromType ty,
2462 {isRebind = false}))
2463 ; elabExp (body, nest, NONE)))
2464 val body =
2465 Cexp.enterLeave
2466 (body,
2467 profileBody andalso !Control.profileBranch,
2468 fn () =>
2469 SourceInfo.function
2470 {name = ("<case " ^ Layout.toString (layPatsPrefix ()) ^ ">") :: nest,
2471 region = regionBody})
2472 val _ =
2473 case resultType of
2474 SOME (resultType, regionResultType) =>
2475 unify
2476 (resultType, Cexp.ty body,
2477 fn (l1, l2) =>
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],
2485 ctxtFb ()]))
2486 | NONE =>
2487 if resultTypeConstraint
2488 then unify
2489 (resTy, Cexp.ty body, fn (l1, l2) =>
2490 (regionBody,
2491 str "function clause expression and result constraint disagree",
2492 align [seq [str "expression: ", l2],
2493 seq [str "constraint: ", l1],
2494 ctxtFb ()]))
2495 else unify
2496 (resTy, Cexp.ty body, fn (l1, l2) =>
2497 (regionBody,
2498 str "function clause with expression of different type",
2499 align [seq [str "expression: ", l2],
2500 seq [str "previous: ", l1],
2501 ctxtFb ()]))
2502 in
2503 {exp = body,
2504 layPat = SOME layPats,
2505 pat = Cpat.tuple pats,
2506 regionPat = regionPats}
2507 end)
2508 val args =
2509 Vector.map
2510 (argTys, fn argTy =>
2511 (Var.newNoname (), argTy))
2512 fun check () =
2513 unify
2514 (Vector.foldr (argTys, resTy, Type.arrow), funTy, fn (l1, l2) =>
2515 (Avar.region func,
2516 seq [str "recursive use of function disagrees with function declaration type: ",
2517 Avar.layout func],
2518 align [seq [str "recursive use: ", l2],
2519 seq [str "function type: ", l1],
2520 ctxt ()]))
2521 val body =
2522 Cexp.casee
2523 {ctxt = ctxtFb,
2524 kind = ("function", "clause"),
2525 nest = nest,
2526 matchDiags = matchDiagsFromNoMatch Cexp.RaiseMatch,
2527 noMatch = Cexp.RaiseMatch,
2528 region = regionFb,
2529 rules = rules,
2530 test = Cexp.tuple (Vector.map (args, Cexp.var))}
2531 val body =
2532 Cexp.enterLeave
2533 (body,
2534 profileBody,
2535 fn () =>
2536 SourceInfo.function
2537 {name = nest,
2538 region = regionFb})
2539 val lambda =
2540 Vector.foldr
2541 (args, body, fn ((arg, argTy), body) =>
2542 Cexp.make
2543 (Cexp.Lambda
2544 (Lambda.make
2545 {arg = arg,
2546 argType = argTy,
2547 body = body,
2548 mayInline = true}),
2549 Type.arrow (argTy, Cexp.ty body)))
2550 val lambda =
2551 case Cexp.node lambda of
2552 Cexp.Lambda lambda => lambda
2553 | _ => Lambda.bogus
2554 in
2555 {check = check,
2556 func = func,
2557 funTy = funTy,
2558 lambda = lambda,
2559 var = var}
2560 end)
2561 val _ =
2562 Vector.foreach
2563 (fbs, fn {check, ...} =>
2564 check ())
2565 val {bound, schemes} =
2566 close
2567 (tyvars',
2568 Vector.map
2569 (fbs, fn {func, funTy, ...} =>
2570 {isExpansive = false,
2571 ty = funTy,
2572 var = func}),
2573 {error = generalizeError,
2574 layoutPrettyTycon = layoutPrettyTycon,
2575 layoutPrettyTyvar = layoutPrettyTyvar})
2576 val _ =
2577 checkSchemes
2578 (Vector.zip
2579 (Vector.map (fbs, #func),
2580 schemes))
2581 val _ = setBound bound
2582 val _ =
2583 Vector.foreach2
2584 (fbs, schemes,
2585 fn ({func, var, ...}, scheme) =>
2586 (Env.extendVar
2587 (E, func, var, scheme,
2588 {isRebind = true})
2589 ; unmarkFunc var))
2590 val decs =
2591 Vector.map
2592 (fbs, fn {lambda, var, ...} =>
2593 {lambda = lambda,
2594 var = var})
2595 in
2596 Decs.single
2597 (Cdec.Fun {decs = decs,
2598 tyvars = bound})
2599 end)
2600 end
2601 | Adec.Local (d, d') =>
2602 let
2603 val res =
2604 Env.localCore
2605 (E,
2606 fn () => elabDec (d, false),
2607 fn decs => Decs.append (decs, elabDec (d', isTop)))
2608 in
2609 res
2610 end
2611 | Adec.Open paths =>
2612 let
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.
2617 *)
2618 val _ =
2619 Vector.foreach
2620 (Vector.map (paths, fn p => Env.lookupLongstrid (E, p)),
2621 fn so => Option.app (so, fn s =>
2622 Env.openStructure (E, s)))
2623 in
2624 Decs.empty
2625 end
2626 | Adec.Overload (p, x, tyvars, ty, xs) =>
2627 TyvarEnv.scope
2628 (tyvars, fn tyvars' =>
2629 let
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.
2634 *)
2635 val ovlds =
2636 Vector.concatV
2637 (Vector.map
2638 (xs, fn x =>
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))
2645 | _ =>
2646 (Control.error
2647 (Longvid.region x,
2648 str "cannot overload",
2649 seq [str "constructor: ", Longvid.layout x])
2650 ; Vector.new0 ())))
2651 val s =
2652 Scheme.make {canGeneralize = false,
2653 tyvars = tyvars',
2654 ty = elabType (ty, {bogusAsUnknown = false})}
2655 val _ =
2656 Vector.foreach
2657 (ovlds,
2658 fn (r, (_, s')) =>
2659 let
2660 val is = Scheme.instantiate s
2661 val is' = Scheme.instantiate s'
2662 in
2663 unify
2664 (#instance is,
2665 #instance is',
2666 fn (l1, l2) =>
2667 (r,
2668 str "variant does not unify with overload",
2669 align [seq [str "overload: ", l1],
2670 seq [str "variant: ", l2],
2671 ctxt ()]))
2672 end)
2673 val _ =
2674 Env.extendOverload
2675 (E, p, x, Vector.map (ovlds, fn (_, vt) => vt), s)
2676 in
2677 Decs.empty
2678 end)
2679 | Adec.SeqDec ds =>
2680 Vector.fold (ds, Decs.empty, fn (d, decs) =>
2681 Decs.append (decs, elabDec (d, isTop)))
2682 | Adec.Type typBind =>
2683 (ignore (elabTypBind typBind)
2684 ; Decs.empty)
2685 | Adec.Val {tyvars, rvbs, vbs} =>
2686 let
2687 val close = TypeEnv.close {region = region}
2688 in
2689 TyvarEnv.scope
2690 (tyvars, fn tyvars' =>
2691 let
2692 val {layoutPrettyTycon, layoutPrettyTyvar, unify, ...} =
2693 DiagUtils.make E
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
2697 * scoping rules.
2698 *)
2699 val vbs =
2700 Vector.map2
2701 (vbs, layVbs, fn ({exp, pat, ...}, layVb) =>
2702 let
2703 fun ctxtVb () =
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)
2709 val exp =
2710 Cexp.enterLeave
2711 (exp,
2712 profileBody
2713 andalso !Control.profileVal
2714 andalso Cexp.isExpansive exp, fn () =>
2715 let
2716 val name =
2717 concat ["<val ",
2718 Layout.toString
2719 (approximatePrefix
2720 (Apat.layout pat)),
2721 ">"]
2722 in
2723 SourceInfo.function {name = name :: nest,
2724 region = regionExp}
2725 end)
2726 in
2727 {ctxtVb = ctxtVb,
2728 exp = exp,
2729 layPat = layPat,
2730 pat = pat,
2731 regionExp = regionExp,
2732 regionPat = regionPat}
2733 end)
2734 val {markFunc, setBound, unmarkFunc} = recursiveFun ()
2735 val elaboratePat = elaboratePat ()
2736 val rvbs =
2737 Vector.map2
2738 (rvbs, layRvbs, fn ({pat, match}, layRvb) =>
2739 let
2740 fun ctxtRvb () =
2741 seq [str "in: ", approximate (layRvb ())]
2742 val regionPat = Apat.region pat
2743 val (pat, bound) =
2744 elaboratePat (pat, E, {bind = false, isRvb = true})
2745 val (nest, var) =
2746 if Vector.length bound = 1
2747 andalso (Type.isUnknown (Cpat.ty pat)
2748 orelse Type.isArrow (Cpat.ty pat))
2749 then let
2750 val (x, x', _) = Vector.first bound
2751 in
2752 (Avar.toString x :: nest, x')
2753 end
2754 else ("_" :: nest, Var.newNoname ())
2755 val _ = markFunc var
2756 val bound =
2757 Vector.map
2758 (bound, fn (x, _, ty) =>
2759 let
2760 val xVid = Avid.fromVar x
2761 val _ =
2762 checkConRedefine
2763 (xVid, "val rec", ctxtRvb)
2764 val _ =
2765 Env.extendVar
2766 (E, x, var, Scheme.fromType ty,
2767 {isRebind = false})
2768 in
2769 (x, var, ty)
2770 end)
2771 in
2772 {bound = bound,
2773 ctxtRvb = ctxtRvb,
2774 match = match,
2775 nest = nest,
2776 pat = pat,
2777 regionPat = regionPat,
2778 patIsConstrained = not (Type.isUnknown (Cpat.ty pat)),
2779 var = var}
2780 end)
2781 val vbs =
2782 Vector.map
2783 (vbs,
2784 fn {ctxtVb, exp, layPat, pat, regionExp, regionPat, ...} =>
2785 let
2786 val (pat, bound) =
2787 elaboratePat (pat, E, {bind = false, isRvb = false})
2788 val _ =
2789 unify
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],
2795 ctxtVb ()]))
2796 in
2797 {bound = bound,
2798 ctxtVb = ctxtVb,
2799 exp = exp,
2800 layPat = layPat,
2801 pat = pat,
2802 regionPat = regionPat}
2803 end)
2804 val rvbs =
2805 Vector.map
2806 (rvbs, fn {bound, ctxtRvb, match, nest, pat, patIsConstrained, regionPat, var, ...} =>
2807 let
2808 val {argType, region, resultType, rules} =
2809 elabMatch (match, nest)
2810 fun check () =
2811 unify
2812 (Cpat.ty pat,
2813 Type.arrow (argType, resultType),
2814 fn (l1, l2) =>
2815 if patIsConstrained
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],
2820 ctxt ()])
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],
2826 ctxt ()]))
2827 val arg = Var.newNoname ()
2828 val body =
2829 Cexp.enterLeave
2830 (Cexp.casee {ctxt = ctxtRvb,
2831 kind = ("recursive function", "rule"),
2832 nest = nest,
2833 matchDiags = matchDiagsFromNoMatch Cexp.RaiseMatch,
2834 noMatch = Cexp.RaiseMatch,
2835 region = region,
2836 rules = rules,
2837 test = Cexp.var (arg, argType)},
2838 profileBody,
2839 fn () => SourceInfo.function {name = nest,
2840 region = region})
2841 val lambda =
2842 Lambda.make {arg = arg,
2843 argType = argType,
2844 body = body,
2845 mayInline = true}
2846 in
2847 {check = check,
2848 bound = bound,
2849 lambda = lambda,
2850 var = var}
2851 end)
2852 val _ =
2853 Vector.foreach
2854 (rvbs, fn {check, ...} =>
2855 check ())
2856 val boundVars =
2857 Vector.concat
2858 [Vector.concatV
2859 (Vector.map
2860 (rvbs, fn {bound, ...} =>
2861 ((Vector.rev o Vector.map)
2862 (bound, fn z =>
2863 (z, {isExpansive = false,
2864 isRebind = true}))))),
2865 Vector.concatV
2866 (Vector.map
2867 (vbs, fn {bound, exp, ...} =>
2868 ((Vector.rev o Vector.map)
2869 (bound, fn z =>
2870 (z, {isExpansive = Cexp.isExpansive exp,
2871 isRebind = false})))))]
2872 val {bound, schemes} =
2873 close
2874 (tyvars',
2875 Vector.map
2876 (boundVars, fn ((var, _, ty), {isExpansive, ...}) =>
2877 {isExpansive = isExpansive,
2878 ty = ty,
2879 var = var}),
2880 {error = generalizeError,
2881 layoutPrettyTycon = layoutPrettyTycon,
2882 layoutPrettyTyvar = layoutPrettyTyvar})
2883 val _ =
2884 checkSchemes
2885 (Vector.zip
2886 (Vector.map (boundVars, #1 o #1),
2887 schemes))
2888 val _ = setBound bound
2889 val _ =
2890 Vector.foreach2
2891 (boundVars, schemes,
2892 fn (((x, x', _), {isRebind, ...}), scheme) =>
2893 Env.extendVar
2894 (E, x, x', scheme,
2895 {isRebind = isRebind}))
2896 val _ =
2897 Vector.foreach
2898 (rvbs, fn {var, ...} =>
2899 unmarkFunc var)
2900 val vbs =
2901 Vector.map
2902 (vbs, fn {ctxtVb, exp, layPat, pat, regionPat, ...} =>
2903 {ctxt = ctxtVb,
2904 exp = exp,
2905 layPat = layPat,
2906 nest = nest,
2907 pat = pat,
2908 regionPat = regionPat})
2909 val rvbs =
2910 Vector.map
2911 (rvbs, fn {lambda, var, ...} =>
2912 {lambda = lambda,
2913 var = 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.
2918 *)
2919 in
2920 Decs.single
2921 (Cdec.Val {matchDiags = matchDiagsFromNoMatch Cexp.RaiseBind,
2922 rvbs = rvbs,
2923 tyvars = bound,
2924 vbs = vbs})
2925 end)
2926 end
2927 val () =
2928 case resolveScope () of
2929 Control.Elaborate.ResolveScope.Dec =>
2930 (reportUnresolvedFlexRecords ()
2931 ; resolveOverloads ())
2932 | _ => ()
2933 in
2934 decs
2935 end) arg
2936 and elabExp (arg: Aexp.t * Nest.t * string option) : Cexp.t =
2937 Trace.traceInfo
2938 (elabExpInfo,
2939 Layout.tuple3
2940 (Aexp.layout,
2941 Nest.layout,
2942 Option.layout String.layout),
2943 Cexp.layoutWithType,
2944 Trace.assertTrue)
2945 (fn (e: Aexp.t, nest, maybeName) =>
2946 let
2947 fun elab e = elabExp (e, nest, NONE)
2948 val {layoutPrettyType, layoutPrettyTycon, layoutPrettyTyvar, unify} =
2949 DiagUtils.make E
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 =>
2955 let
2956 val (r, m, d) = f z
2957 in
2958 (r, m, align [d, ctxt ()])
2959 end)
2960 val region = Aexp.region e
2961 in
2962 case Aexp.node e of
2963 Aexp.Andalso (el, er) =>
2964 let
2965 fun doit (e, br) =
2966 let
2967 val ce = elab e
2968 val _ =
2969 unify
2970 (Cexp.ty ce, Type.bool,
2971 fn (l, _) =>
2972 (Aexp.region e,
2973 str (concat
2974 [br, " branch of andalso not of type bool"]),
2975 seq [str "branch: ", l]))
2976 in
2977 ce
2978 end
2979 val cel = doit (el, "left")
2980 val cer = doit (er, "right")
2981 val e = Cexp.andAlso (cel, cer)
2982 in
2983 Cexp.make (Cexp.node e, Type.bool)
2984 end
2985 | Aexp.App (ef, ea) =>
2986 let
2987 val cef = elab ef
2988 val cea = elab ea
2989 val isCon =
2990 case Cexp.node cef of
2991 Cexp.Con _ => true
2992 | _ => false
2993 val (argType, resultType) =
2994 case Type.deArrowOpt (Cexp.ty cef) of
2995 SOME types => types
2996 | NONE =>
2997 let
2998 val types = (Type.new (), Type.new ())
2999 val _ =
3000 unify (Cexp.ty cef, Type.arrow types,
3001 fn (l, _) =>
3002 if isCon
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]))
3009 in
3010 types
3011 end
3012 val _ =
3013 unify
3014 (argType, Cexp.ty cea, fn (l1, l2) =>
3015 (region,
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]]))
3020 in
3021 Cexp.make (Cexp.App (cef, cea), resultType)
3022 end
3023 | Aexp.Case (e, m) =>
3024 let
3025 val e = elab e
3026 val {argType, rules, ...} = elabMatch (m, nest)
3027 val _ =
3028 unify
3029 (Cexp.ty e, argType, fn (l1, l2) =>
3030 (region,
3031 str "case object and match argument disagree",
3032 align [seq [str "case object: ", l1],
3033 seq [str "match argument: ", l2]]))
3034 in
3035 Cexp.casee {ctxt = ctxt,
3036 kind = ("case", "rule"),
3037 nest = nest,
3038 matchDiags = matchDiagsFromNoMatch Cexp.RaiseMatch,
3039 noMatch = Cexp.RaiseMatch,
3040 region = Amatch.region m,
3041 rules = rules,
3042 test = e}
3043 end
3044 | Aexp.Const c =>
3045 elabConst
3046 (c,
3047 {layoutPrettyType = #1 o layoutPrettyType},
3048 fn (resolve, ty) => Cexp.make (Cexp.Const resolve, ty),
3049 {false = Cexp.falsee,
3050 true = Cexp.truee})
3051 | Aexp.Constraint (e, t') =>
3052 let
3053 val e = elab e
3054 val t' = elabType (t', {bogusAsUnknown = true})
3055 val _ =
3056 unify
3057 (Cexp.ty e, t', fn (l1, l2) =>
3058 (region,
3059 str "expression and constraint disagree",
3060 align [seq [str "expression: ", l1],
3061 seq [str "constraint: ", l2]]))
3062 in
3063 Cexp.make (Cexp.node e, t')
3064 end
3065 | Aexp.FlatApp items => elab (Parse.parseExp (items, E, ctxt))
3066 | Aexp.Fn match =>
3067 let
3068 val nest =
3069 case maybeName of
3070 NONE => "fn" :: nest
3071 | SOME s => s :: nest
3072 val {arg, argType, body} =
3073 elabMatchFn
3074 (match, nest, ctxt,
3075 ("function", "rule"), Cexp.RaiseMatch)
3076 val body =
3077 Cexp.enterLeave
3078 (body,
3079 profileBody,
3080 fn () => SourceInfo.function {name = nest,
3081 region = region})
3082 in
3083 Cexp.make (Cexp.Lambda (Lambda.make {arg = arg,
3084 argType = argType,
3085 body = body,
3086 mayInline = true}),
3087 Type.arrow (argType, Cexp.ty body))
3088 end
3089 | Aexp.Handle (try, match) =>
3090 let
3091 val try = elab try
3092 val {arg, argType, body} =
3093 elabMatchFn
3094 (match, nest, ctxt,
3095 ("handler", "rule"), Cexp.RaiseAgain)
3096 val _ =
3097 unify
3098 (Cexp.ty try, Cexp.ty body, fn (l1, l2) =>
3099 (region,
3100 str "expression and handler disagree",
3101 align [seq [str "expression: ", l1],
3102 seq [str "handler: ", l2]]))
3103 val _ =
3104 unify
3105 (argType, Type.exn, fn (l1, _) =>
3106 (Amatch.region match,
3107 str "handler match argument not of type exn",
3108 seq [str "argument: ", l1]))
3109 in
3110 Cexp.make (Cexp.Handle {catch = (arg, Type.exn),
3111 handler = body,
3112 try = try},
3113 Cexp.ty try)
3114 end
3115 | Aexp.If (a, b, c) =>
3116 let
3117 val a' = elab a
3118 val b' = elab b
3119 val c' = elab c
3120 val _ =
3121 unify
3122 (Cexp.ty a', Type.bool, fn (l1, _) =>
3123 (Aexp.region a,
3124 str "if test not of type bool",
3125 seq [str "test: ", l1]))
3126 val _ =
3127 unify
3128 (Cexp.ty b', Cexp.ty c', fn (l1, l2) =>
3129 (region,
3130 str "then and else branches disagree",
3131 align [seq [str "then: ", l1],
3132 seq [str "else: ", l2]]))
3133 val (b', c') =
3134 if not (!Control.profileBranch)
3135 then (b', c')
3136 else
3137 let
3138 fun wrap (e, e', name) =
3139 Cexp.enterLeave
3140 (e', profileBody, fn () =>
3141 SourceInfo.function
3142 {name = name :: nest,
3143 region = Aexp.region e})
3144 in
3145 (wrap (b, b', "<case true>"), wrap (c, c', "<case false>"))
3146 end
3147 in
3148 Cexp.iff (a', b', c')
3149 end
3150 | Aexp.Let (d, e) =>
3151 let
3152 val res =
3153 Env.scope
3154 (E, fn () =>
3155 let
3156 val time = Time.now ()
3157 val d' = Decs.toVector (elabDec (d, nest, false))
3158 val e' = elab e
3159 val ty = Cexp.ty e'
3160 val ty =
3161 case Type.checkTime (ty, time,
3162 {layoutPrettyTycon = layoutPrettyTycon,
3163 layoutPrettyTyvar = layoutPrettyTyvar}) of
3164 NONE => ty
3165 | SOME (lay, ty, {tycons, ...}) =>
3166 let
3167 val tycons =
3168 List.map
3169 (tycons, fn c =>
3170 (c, layoutPrettyTycon c))
3171 val tycons =
3172 List.insertionSort
3173 (tycons, fn ((_, l1), (_, l2)) =>
3174 String.<= (Layout.toString l1,
3175 Layout.toString l2))
3176 val _ =
3177 Control.error
3178 (region,
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],
3185 (align o List.map)
3186 (tycons, fn (c, _) =>
3187 seq [str "escape from: ",
3188 Region.layout (Tycon.region c)]),
3189 ctxt ()])
3190 in
3191 ty
3192 end
3193 in
3194 Cexp.make (Cexp.Let (d', e'), ty)
3195 end)
3196 in
3197 res
3198 end
3199 | Aexp.List es =>
3200 let
3201 val es' = Vector.map (es, elab)
3202 in
3203 Cexp.make (Cexp.List es',
3204 unifyList
3205 (Vector.map2 (es, es', fn (e, e') =>
3206 (Cexp.ty e', Aexp.region e)),
3207 unify))
3208 end
3209 | Aexp.Orelse (el, er) =>
3210 let
3211 fun doit (e, br) =
3212 let
3213 val ce = elab e
3214 val _ =
3215 unify
3216 (Cexp.ty ce, Type.bool,
3217 fn (l, _) =>
3218 (Aexp.region e,
3219 str (concat
3220 [br, " branch of orelse not of type bool"]),
3221 seq [str "branch: ", l]))
3222 in
3223 ce
3224 end
3225 val cel = doit (el, "left")
3226 val cer = doit (er, "right")
3227 val e = Cexp.orElse (cel, cer)
3228 in
3229 Cexp.make (Cexp.node e, Type.bool)
3230 end
3231 | Aexp.Paren e => elab e
3232 | Aexp.Prim kind =>
3233 let
3234 fun elabAndExpandTy ty =
3235 let
3236 val elabedTy = elabType (ty, {bogusAsUnknown = false})
3237 val expandedTy =
3238 Type.hom
3239 (elabedTy, {con = Type.con,
3240 expandOpaque = true,
3241 record = Type.record,
3242 replaceSynonyms = false,
3243 var = Type.var})
3244 in
3245 (elabedTy, expandedTy)
3246 end
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.
3251 *)
3252 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
3253 fun etaExtraNoWrap {expandedTy,
3254 extra,
3255 prim: Type.t Prim.t}: Cexp.t =
3256 case Type.deArrowOpt expandedTy of
3257 NONE => primApp {args = extra,
3258 prim = prim,
3259 result = expandedTy}
3260 | SOME (argType, bodyType) =>
3261 let
3262 val arg = Var.newNoname ()
3263 fun app args =
3264 primApp {args = Vector.concat [extra, args],
3265 prim = prim,
3266 result = bodyType}
3267 val body =
3268 case Type.deTupleOpt argType of
3269 NONE =>
3270 app (Vector.new1
3271 (Cexp.var (arg, argType)))
3272 | SOME ts =>
3273 let
3274 val vars =
3275 Vector.map
3276 (ts, fn t =>
3277 (Var.newNoname (), t))
3278 in
3279 Cexp.casee
3280 {ctxt = fn _ => empty,
3281 kind = ("", ""),
3282 nest = [],
3283 matchDiags = matchDiagsFromNoMatch Cexp.Impossible,
3284 noMatch = Cexp.Impossible,
3285 region = Region.bogus,
3286 rules = Vector.new1
3287 {exp = app (Vector.map
3288 (vars, Cexp.var)),
3289 layPat = NONE,
3290 pat = Cpat.tuple
3291 (Vector.map
3292 (vars, Cpat.var)),
3293 regionPat = Region.bogus},
3294 test = Cexp.var (arg, argType)}
3295 end
3296 in
3297 (Cexp.lambda o Lambda.make)
3298 {arg = arg,
3299 argType = argType,
3300 body = body,
3301 mayInline = true}
3302 end
3303 fun etaNoWrap {expandedTy,
3304 prim: Type.t Prim.t} : Cexp.t =
3305 etaExtraNoWrap {expandedTy = expandedTy,
3306 extra = Vector.new0 (),
3307 prim = prim}
3308 fun eta {elabedTy, expandedTy,
3309 prim: Type.t Prim.t} : Cexp.t =
3310 wrap (etaNoWrap {expandedTy = expandedTy,
3311 prim = prim},
3312 elabedTy)
3313 fun lookConst {default: string option,
3314 elabedTy, expandedTy,
3315 name: string} =
3316 let
3317 fun bug () =
3318 let
3319 val _ =
3320 Control.error
3321 (region,
3322 seq [str "strange constant type: ",
3323 Type.layout expandedTy],
3324 empty)
3325 in
3326 Error.bug "ElaborateCore.elabExp.lookConst"
3327 end
3328 in
3329 case Type.deConOpt expandedTy of
3330 NONE => bug ()
3331 | SOME (c, ts) =>
3332 let
3333 val ct =
3334 if Tycon.equals (c, Tycon.bool)
3335 then ConstType.Bool
3336 else if Tycon.isIntX c
3337 then case Tycon.deIntX c of
3338 NONE => bug ()
3339 | SOME is =>
3340 ConstType.Word
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
3348 andalso
3349 (case (Type.deConOpt
3350 (Vector.first ts)) of
3351 NONE => false
3352 | SOME (c, _) =>
3353 Tycon.isCharX c
3354 andalso (Tycon.deCharX c = CharSize.C8))
3355 then ConstType.String
3356 else bug ()
3357 val finish =
3358 fn () => ! Const.lookup ({default = default,
3359 name = name}, ct)
3360 in
3361 Cexp.make (Cexp.Const finish, elabedTy)
3362 end
3363 end
3364 val check = fn (c, n) => check (c, n, region)
3365 datatype z = datatype Ast.PrimKind.t
3366 in
3367 case kind of
3368 Address {attributes, name, ty} =>
3369 let
3370 val () =
3371 check (ElabControl.allowFFI, "_address")
3372 val (elabedTy, expandedTy) =
3373 elabAndExpandTy ty
3374 in
3375 address {attributes = attributes,
3376 elabedTy = elabedTy,
3377 expandedTy = expandedTy,
3378 name = name,
3379 region = region,
3380 layoutPrettyType = #1 o layoutPrettyType}
3381 end
3382 | BuildConst {name, ty} =>
3383 let
3384 val () =
3385 check (ElabControl.allowConstant,
3386 "_build_const")
3387 val (elabedTy, expandedTy) =
3388 elabAndExpandTy ty
3389 in
3390 lookConst {default = NONE,
3391 elabedTy = elabedTy,
3392 expandedTy = expandedTy,
3393 name = name}
3394 end
3395 | CommandLineConst {name, ty, value} =>
3396 let
3397 val () =
3398 check (ElabControl.allowConstant,
3399 "_command_line_const")
3400 val (elabedTy, expandedTy) =
3401 elabAndExpandTy ty
3402 val value =
3403 elabConst
3404 (value,
3405 {layoutPrettyType = #1 o layoutPrettyType},
3406 fn (resolve, _) =>
3407 case resolve () of
3408 Const.Word w =>
3409 IntInf.toString (WordX.toIntInf w)
3410 | c => Const.toString c,
3411 {false = "false", true = "true"})
3412 in
3413 lookConst {default = SOME value,
3414 elabedTy = elabedTy,
3415 expandedTy = expandedTy,
3416 name = name}
3417 end
3418 | Const {name, ty} =>
3419 let
3420 val () =
3421 check (ElabControl.allowConstant,
3422 "_const")
3423 val (elabedTy, expandedTy) =
3424 elabAndExpandTy ty
3425 in
3426 lookConst {default = NONE,
3427 elabedTy = elabedTy,
3428 expandedTy = expandedTy,
3429 name = name}
3430 end
3431 | Export {attributes, name, ty} =>
3432 let
3433 val () =
3434 check (ElabControl.allowFFI, "_export")
3435 val (elabedTy, expandedTy) =
3436 elabAndExpandTy ty
3437 fun error () =
3438 Control.error
3439 (region,
3440 str "invalid type for _export",
3441 #1 (layoutPrettyType elabedTy))
3442 val (expandedCfTy, elabedExportTy) =
3443 Exn.withEscape
3444 (fn escape =>
3445 let
3446 val error = fn () =>
3447 (error ()
3448 ; ignore (escape (Type.arrow (Type.unit, Type.unit),
3449 elabedTy))
3450 ; Error.bug "ElaborateCore.elabExp.Export.escape")
3451 in
3452 case Type.deArrowOpt expandedTy of
3453 NONE => error ()
3454 | SOME (argTy, resTy) =>
3455 (case Type.deArrowOpt argTy of
3456 NONE => error ()
3457 | SOME _ =>
3458 let
3459 val () =
3460 if Type.isUnit resTy
3461 then ()
3462 else error ()
3463 in
3464 (argTy, elabedTy)
3465 end)
3466 end)
3467 val exp =
3468 Env.scope
3469 (E, fn () =>
3470 (Env.openStructure
3471 (E, valOf (!Env.Structure.ffi))
3472 ; elab (export {attributes = attributes,
3473 elabedTy = elabedTy,
3474 expandedTy = expandedCfTy,
3475 name = name,
3476 region = region,
3477 layoutPrettyType = #1 o layoutPrettyType})))
3478 val _ =
3479 unify
3480 (Cexp.ty exp,
3481 Type.arrow (expandedCfTy, Type.unit),
3482 fn (l1, l2) =>
3483 (region,
3484 str "_export unify bug",
3485 align [seq [str "inferred: ", l1],
3486 seq [str "expanded: ", l2]]))
3487 in
3488 wrap (exp, elabedExportTy)
3489 end
3490 | IImport {attributes, ty} =>
3491 let
3492 val () =
3493 check (ElabControl.allowFFI, "_import")
3494 val (elabedTy, expandedTy) =
3495 elabAndExpandTy ty
3496 fun error () =
3497 Control.error
3498 (region,
3499 str "invalid type for _import",
3500 #1 (layoutPrettyType elabedTy))
3501 val (expandedFPtrTy, expandedCfTy) =
3502 Exn.withEscape
3503 (fn escape =>
3504 let
3505 val error = fn () =>
3506 (error ()
3507 ; ignore (escape (Type.cpointer,
3508 Type.arrow (Type.unit, Type.unit)))
3509 ; Error.bug "ElaborateCore.elabExp.IImport.escape")
3510 in
3511 case Type.deArrowOpt expandedTy of
3512 NONE => error ()
3513 | SOME (fptrTy, cfTy) => (fptrTy, cfTy)
3514 end)
3515 val () =
3516 case Type.toCPtrType expandedFPtrTy of
3517 NONE => (error (); ())
3518 | SOME _ => ()
3519 val fptr = Var.newNoname ()
3520 val fptrArg = Cexp.var (fptr, expandedFPtrTy)
3521 in
3522 wrap
3523 ((Cexp.lambda o Lambda.make)
3524 {arg = fptr,
3525 argType = expandedFPtrTy,
3526 body = etaExtraNoWrap {expandedTy = expandedCfTy,
3527 extra = Vector.new1 fptrArg,
3528 prim = import
3529 {attributes = attributes,
3530 name = NONE,
3531 region = region,
3532 elabedTy = elabedTy,
3533 expandedTy = expandedCfTy,
3534 layoutPrettyType = #1 o layoutPrettyType}},
3535 mayInline = true},
3536 elabedTy)
3537 end
3538 | Import {attributes, name, ty} =>
3539 let
3540 val () =
3541 check (ElabControl.allowFFI, "_import")
3542 val (elabedTy, expandedTy) =
3543 elabAndExpandTy ty
3544 in
3545 eta ({elabedTy = elabedTy,
3546 expandedTy = expandedTy,
3547 prim = import {attributes = attributes,
3548 name = SOME name,
3549 region = region,
3550 elabedTy = elabedTy,
3551 expandedTy = expandedTy,
3552 layoutPrettyType = #1 o layoutPrettyType}})
3553 end
3554 | ISymbol {ty} =>
3555 let
3556 val () =
3557 check (ElabControl.allowFFI, "_symbol")
3558 val (elabedTy, expandedTy) =
3559 elabAndExpandTy ty
3560 in
3561 symbolIndirect {elabedTy = elabedTy,
3562 expandedTy = expandedTy,
3563 region = region,
3564 layoutPrettyType = #1 o layoutPrettyType}
3565 end
3566 | Prim {name, ty} =>
3567 let
3568 val () =
3569 check (ElabControl.allowPrim,
3570 "_prim")
3571 val (elabedTy, expandedTy) =
3572 elabAndExpandTy ty
3573 val prim =
3574 case Prim.fromString name of
3575 NONE =>
3576 (Control.error
3577 (region,
3578 str (concat ["unknown primitive: ",
3579 name]),
3580 empty)
3581 ; Prim.bogus)
3582 | SOME p => p
3583 in
3584 eta {elabedTy = elabedTy,
3585 expandedTy = expandedTy,
3586 prim = prim}
3587 end
3588 | Symbol {attributes, name, ty} =>
3589 let
3590 val () =
3591 check (ElabControl.allowFFI, "_symbol")
3592 val (elabedTy, expandedTy) =
3593 elabAndExpandTy ty
3594 in
3595 symbolDirect {attributes = attributes,
3596 elabedTy = elabedTy,
3597 expandedTy = expandedTy,
3598 name = name,
3599 region = region,
3600 layoutPrettyType = #1 o layoutPrettyType}
3601 end
3602 end
3603 | Aexp.Raise exn =>
3604 let
3605 val region = Aexp.region exn
3606 val exn = elab exn
3607 val _ =
3608 unify
3609 (Cexp.ty exn, Type.exn, fn (l1, _) =>
3610 (region,
3611 str "raise object not of type exn",
3612 seq [str "object: ", l1]))
3613 val resultType = Type.new ()
3614 in
3615 Cexp.enterLeave
3616 (Cexp.make (Cexp.Raise exn, resultType),
3617 profileBody andalso !Control.profileRaise,
3618 fn () => SourceInfo.function {name = "<raise>" :: nest,
3619 region = region})
3620 end
3621 | Aexp.Record r =>
3622 let
3623 val r = Record.map (r, elab o #2)
3624 val ty =
3625 Type.record
3626 (SortedRecord.fromVector
3627 (Record.toVector (Record.map (r, Cexp.ty))))
3628 in
3629 Cexp.make (Cexp.Record r, ty)
3630 end
3631 | Aexp.Selector f => elab (Aexp.selector (f, region))
3632 | Aexp.Seq es =>
3633 let
3634 val es' = Vector.map (es, elab)
3635 val last = Vector.length es - 1
3636 (* Diagnose expressions before a ; that don't return unit. *)
3637 val _ =
3638 let
3639 (* Technically, wrong scope for region;
3640 * but saving environment would probably
3641 * be expensive.
3642 *)
3643 fun doit f =
3644 Vector.foreachi2
3645 (es, es', fn (i, e, e') =>
3646 if i = last orelse Type.isUnit (Cexp.ty e')
3647 then ()
3648 else List.push
3649 (sequenceNonUnitChecks, fn () =>
3650 if Type.isUnit (Cexp.ty e')
3651 then ()
3652 else f (Aexp.region e,
3653 str "sequence expression not of type unit",
3654 align [seq [str "type: ", layoutPrettyTypeBracket (Cexp.ty e')],
3655 ctxt ()])))
3656 in
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
3661 end
3662 in
3663 Cexp.make (Cexp.Seq es', Cexp.ty (Vector.sub (es', last)))
3664 end
3665 | Aexp.Var {name = id, ...} =>
3666 let
3667 fun dontCare () =
3668 Cexp.var (Var.newNoname (), Type.new ())
3669 in
3670 case Env.lookupLongvid (E, id) of
3671 NONE => dontCare ()
3672 | SOME (vid, scheme) =>
3673 let
3674 val {args, instance} = Scheme.instantiate scheme
3675 fun con c = Cexp.Con (c, args ())
3676 val e =
3677 case vid of
3678 Vid.Con c => con c
3679 | Vid.Exn c => con c
3680 | Vid.Overload (p, yts) =>
3681 let
3682 val resolve =
3683 Promise.lazy
3684 (fn () =>
3685 case Vector.peekMap
3686 (yts,
3687 fn (x, s) =>
3688 let
3689 val is = Scheme.instantiate s
3690 in
3691 if Type.canUnify
3692 (instance, #instance is)
3693 then SOME (x, SOME is)
3694 else NONE
3695 end) of
3696 NONE =>
3697 let
3698 (* Technically, wrong scope for region;
3699 * but saving environment would probably
3700 * be expensive.
3701 *)
3702 val _ =
3703 Control.error
3704 (region,
3705 seq [str "variable not overloaded at type: ",
3706 str (Longvid.toString id)],
3707 seq [str "type: ", #1 (layoutPrettyType instance)])
3708 in
3709 {id = Var.newNoname (),
3710 args = Vector.new0 ()}
3711 end
3712 | SOME (y, is) =>
3713 (unify (instance,
3714 #instance (valOf is), fn _ =>
3715 Error.bug "ElaborateCore.elabExp: Var:overload unify")
3716 ; {id = y, args = #args (valOf is) ()}))
3717 val _ =
3718 List.push (overloadChecks, (p, ignore o resolve))
3719 in
3720 Cexp.Var (#id o resolve, #args o resolve)
3721 end
3722 | Vid.Var x =>
3723 Cexp.Var (fn () => x,
3724 case ! (recursiveTargs x) of
3725 NONE => args
3726 | SOME f => f)
3727 in
3728 Cexp.make (e, instance)
3729 end
3730 end
3731 | Aexp.Vector es =>
3732 let
3733 val _ = check (ElabControl.allowVectorExps, "Vector expressions", Aexp.region e)
3734 val es' = Vector.map (es, elab)
3735 in
3736 Cexp.make (Cexp.Vector es',
3737 unifyVector
3738 (Vector.map2 (es, es', fn (e, e') =>
3739 (Cexp.ty e', Aexp.region e)),
3740 unify))
3741 end
3742 | Aexp.While {expr, test} =>
3743 let
3744 val test' = elab test
3745 val _ =
3746 unify
3747 (Cexp.ty test', Type.bool, fn (l1, _) =>
3748 (Aexp.region test,
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. *)
3753 val _ =
3754 let
3755 (* Technically, wrong scope for region;
3756 * but saving environment would probably
3757 * be expensive.
3758 *)
3759 fun doit f =
3760 if Type.isUnit (Cexp.ty expr')
3761 then ()
3762 else List.push
3763 (sequenceNonUnitChecks, fn () =>
3764 if Type.isUnit (Cexp.ty expr')
3765 then ()
3766 else f (Aexp.region expr,
3767 str "while body not of type unit",
3768 align [seq [str "body: ", layoutPrettyTypeBracket (Cexp.ty expr')],
3769 ctxt ()]))
3770 in
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
3775 end
3776 in
3777 Cexp.whilee {expr = expr', test = test'}
3778 end
3779 end) arg
3780 and elabMatchFn (m: Amatch.t, nest, ctxt, kind, noMatch) =
3781 let
3782 val arg = Var.newNoname ()
3783 val {argType, region, rules, ...} = elabMatch (m, nest)
3784 val body =
3785 Cexp.casee {ctxt = ctxt,
3786 kind = kind,
3787 nest = nest,
3788 matchDiags = matchDiagsFromNoMatch noMatch,
3789 noMatch = noMatch,
3790 region = region,
3791 rules = rules,
3792 test = Cexp.var (arg, argType)}
3793 in
3794 {arg = arg,
3795 argType = argType,
3796 body = body}
3797 end
3798 and elabMatch (m: Amatch.t, nest: Nest.t) =
3799 let
3800 val {unify, ...} = DiagUtils.make E
3801 fun ctxt () =
3802 seq [str "in: ", approximate (Amatch.layout m)]
3803 val unify = fn (a, b, f) =>
3804 unify (a, b, fn z =>
3805 let
3806 val (r, m, d) = f z
3807 in
3808 (r, m, align [d, ctxt ()])
3809 end)
3810 val region = Amatch.region m
3811 val Amatch.T rules = Amatch.node m
3812 val argType = Type.new ()
3813 val resultType = Type.new ()
3814 val rules =
3815 Vector.map
3816 (rules, fn (pat, exp) =>
3817 Env.scope
3818 (E, fn () =>
3819 let
3820 fun layPat () = approximate (Apat.layout pat)
3821 val patOrig = pat
3822 val (pat, _) =
3823 elaboratePat () (pat, E, {bind = true, isRvb = false})
3824 val _ =
3825 unify
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]]))
3831 val expOrig = exp
3832 val exp = elabExp (exp, nest, NONE)
3833 val _ =
3834 unify
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]]))
3840 val exp =
3841 Cexp.enterLeave
3842 (exp,
3843 profileBody andalso !Control.profileBranch,
3844 fn () =>
3845 let
3846 val name =
3847 concat ["<case ",
3848 Layout.toString
3849 (approximatePrefix
3850 (Apat.layout patOrig)),
3851 ">"]
3852 in
3853 SourceInfo.function {name = name :: nest,
3854 region = Aexp.region expOrig}
3855 end)
3856 in
3857 {exp = exp,
3858 layPat = SOME layPat,
3859 pat = pat,
3860 regionPat = Apat.region patOrig}
3861 end))
3862 in
3863 {argType = argType,
3864 region = region,
3865 resultType = resultType,
3866 rules = rules}
3867 end
3868 val ds = elabDec (Scope.scope d, nest, true)
3869 in
3870 ds
3871 end
3872
3873 end
mlton packaging