![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to equal.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / translate|
Return to equal.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / translate |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* equal.sml *)
3: signature EQUAL =
4: sig
5: structure Basics : BASICS
6: structure Lambda : LAMBDA
7: val equal : Basics.ty -> Lambda.lexp
8: end
9:
10: structure Equal : EQUAL =
11: struct
12:
13: structure Basics : BASICS = Basics
14: structure Lambda : LAMBDA = Lambda
15:
16: open ErrorMsg Basics Lambda Access BasicTypes TypesUtil
17:
18: fun translatepath [v] = VAR v
19: | translatepath (x::p) = SELECT(x,translatepath p)
20: | translatepath nil = ErrorMsg.impossible "equal.translatepath nil"
21:
22: fun argType(POLYty{tyfun=TYFUN{arity,body=CONty(_,[domain,_])},...}, args) =
23: applyTyfun(TYFUN{arity=arity,body=domain},args)
24: | argType(CONty(_,[argty,_]), []) = argty
25: | argType _ = impossible "Equal.argType"
26:
27:
28: exception Poly
29:
30: fun atomeq tyc =
31: if eqTycon(tyc,!intTycon)
32: orelse eqTycon(tyc,!boolTycon)
33: orelse eqTycon(tyc,!refTycon)
34: orelse eqTycon(tyc,!arrayTycon) then PRIM P.ieql
35: else if eqTycon(tyc,!realTycon) then PRIM P.feql
36: else if eqTycon(tyc,!stringTycon) then
37: translatepath(!CoreInfo.stringequalPath)
38: else raise Poly
39:
40: exception Notfound
41:
42: val trueLexp = CON(trueDcon,RECORD[])
43: val falseLexp = CON(falseDcon,RECORD[])
44:
45: fun equal (concreteType : ty) : lexp =
46: let val cache : (ty * lexp * lexp ref) list ref = ref nil
47: fun enter ty =
48: let val v = VAR(mkLvar())
49: val r = ref v
50: in if !System.Control.debugging
51: then (print "enter: "; PrintType.printType ty; print "\n")
52: else ();
53: cache := (ty, v, r) :: !cache; (v,r)
54: end
55: fun find ty =
56: let fun f ((t,v,e)::r) = if equalType(ty,t) then v else f r
57: | f nil = (if !System.Control.debugging
58: then print "find-notfound\n"
59: else ();
60: raise Notfound)
61: in if !System.Control.debugging
62: then (print "find: "; PrintType.printType ty; print "\n")
63: else ();
64: f (!cache)
65: end
66:
67: fun test(ty) =
68: (if !System.Control.debugging
69: then (print "test: "; PrintType.printType ty; print "\n")
70: else ();
71: case ty
72: of VARty(ref(INSTANTIATED t)) => test t
73: | FLEXRECORDty(ref(CLOSED t)) => test t
74: | CONty(ref(tyc as TYCON{kind=ABStyc,eq=ref YES,...}),tyl) => atomeq tyc
75: | CONty(ref(tyc as TYCON{kind=ABStyc,eq=ref NO,...}),tyl) =>
76: impossible("Attempt to test opaque type for equality: "
77: ^ Symbol.name(tycName tyc))
78: | CONty(ref(TYCON{kind=DEFtyc _,...}),tyl) => test(reduceType ty)
79: | CONty(ref(tyc as
80: TYCON{kind=DATAtyc([DATACON{const=false,rep,typ,...}]),
81: ...}),
82: tyl) =>
83: (case rep
84: of TRANSPARENT =>
85: (find ty handle Notfound =>
86: let val (eqv,patch) = enter ty
87: val v = mkLvar()
88: val ty' = argType(!typ,tyl)
89: in patch := FN(v,APP(test ty', VAR v));
90: eqv
91: end)
92: | REF => atomeq tyc
93: | _ => impossible "Equal #498")
94: | CONty(ref(TYCON{kind,...}), tyl) =>
95: (find ty
96: handle Notfound =>
97: let val v = mkLvar() and x=mkLvar() and y=mkLvar()
98: val (eqv, patch) = enter ty
99: fun inside (DATACON{const=true,...}) = trueLexp
100: | inside (c as DATACON{typ, const=false,...}) =
101: APP(test(argType(!typ,tyl)),
102: RECORD[DECON(c, VAR x),
103: DECON(c, VAR y)])
104: val body =
105: case kind
106: of DATAtyc([dcon]) =>
107: inside dcon
108: | DATAtyc(dcons) =>
109: let fun concase dcon =
110: (DATAcon(dcon),
111: SWITCH(VAR y,[(DATAcon(dcon), inside dcon)],
112: SOME(falseLexp)))
113: in SWITCH(VAR x,map concase dcons,NONE)
114: end
115: | RECORDtyc _ =>
116: let fun loop(n,[ty]) =
117: APP(test(ty), RECORD[SELECT(n, VAR x),
118: SELECT(n, VAR y)])
119: | loop(n,ty::r) =
120: SWITCH(loop(n,[ty]),
121: [(DATAcon(trueDcon), loop(n+1,r)),
122: (DATAcon(falseDcon), falseLexp)],
123: NONE)
124: | loop(_,nil) = trueLexp
125: in loop(0,tyl)
126: end
127: | _ => raise Poly
128: in patch := FN(v,APP(FN(x,APP(FN(y,body),
129: SELECT(1,VAR v))),
130: SELECT(0,VAR v)));
131: eqv
132: end)
133: | _ => raise Poly)
134:
135: val body = test(concreteType)
136:
137: in FIX(map (fn (_,VAR v,_) => v | _ => impossible "Equal #324") (!cache),
138: map (fn (_,_,e) => !e) (!cache),
139: body)
140: end
141: handle Poly => translatepath(!CoreInfo.polyequalPath)
142: | Syntax =>
143: (print "equal: type = ";
144: PrintType.resetPrintType();
145: PrintType.printType concreteType; print"\n";
146: RECORD[])
147:
148: end (* struct *)
149:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.