Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |