1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
(* Copyright 1996 by AT&T Bell Laboratories *)
(* conrep.sml *)
signature CONREP =
sig
val infer : bool -> (Symbol.symbol * bool * Types.ty) list
-> (Access.conrep list * Access.consig)
end (* signature CONREP *)
structure ConRep : CONREP =
struct
local open Access Types
in
fun err s = ErrorMsg.impossible ("Conrep: "^s)
fun count predicate l =
let fun test (a::rest,acc) = test (rest,if predicate a then 1+acc else acc)
| test (nil,acc) = acc
in test (l,0)
end
fun reduce ty =
case TypesUtil.headReduceType ty
of POLYty{tyfun=TYFUN{body,...},...} => reduce body
| ty => ty
fun notconst(_,true,_) = false
(*
| notconst(_,_,CONty(_,[t,_])) =
(case (reduce t)
of CONty(RECORDtyc nil,_) => false
| _ => true)
*)
| notconst _ = true
(*
* fun show((sym,_,_)::syms, r::rs) =
* (print(Symbol.name sym); print ": ";
* PPBasics.ppRep r; print "\n"; show(syms,rs))
* | show _ = (print "\n")
*)
(* the first argument indicates whether this is a recursive datatypes *)
fun infer false ([(_, false, CONty(_,[ty,_]))]) =
(case (reduce ty)
of (* (CONty(RECORDtyc nil, _)) => ([CONSTANT 0], CSIG (0,1))
| *) _ => ([UNTAGGED], CSIG(1,0)) (* [TRANSPARENT] *))
(* The TRANSPARENT conrep is temporarily turned off;
it should be working very soon. Ask zsh. *)
| infer _ cons =
let val multiple = (count notconst cons) > 1
fun decide (ctag,vtag, (_,true,_)::rest, reps) =
if multiple andalso !ElabControl.boxedconstconreps
then decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps)
else decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps)
| decide (ctag,vtag, (_,false,CONty(_,[ty,_]))::rest, reps) =
(case (reduce ty, multiple)
of (*
(CONty(RECORDtyc nil,_),_) =>
decide(ctag+1, vtag, rest, (CONSTANT ctag) :: reps)
| *)
(_, true) =>
decide(ctag, vtag+1, rest, (TAGGED vtag) :: reps)
| (_, false) =>
decide(ctag, vtag+1, rest, (UNTAGGED :: reps)))
| decide (_, _, _::_, _) = err "unexpected conrep-decide"
| decide (ctag, vtag, [], reps) = (rev reps, CSIG(vtag,ctag))
in decide(0, 0, cons, [])
end
(*** val infer = fn l => let val l' = infer l in show(l,l'); l' end ***)
end (* local *)
end (* structure ConRep *)
|
