Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/ckit/src/ast-utils/equality/eq-ctype.sml
ViewVC logotype

Annotation of /sml/trunk/ckit/src/ast-utils/equality/eq-ctype.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 597 - (view) (download)

1 : dbm 597 (* Copyright (c) 1998 by Lucent Technologies *)
2 :    
3 :     structure EqCType (*: EQCTYPE*) = struct
4 :    
5 :     structure Tid = Tid
6 :     structure Pid = Pid
7 :     structure B = Bindings
8 :     structure CT = CType
9 :     open CT
10 :    
11 :     exception eqFail
12 :    
13 :     fun warning s = (print "Warning: EqCType: "; print s; print "\n")
14 :    
15 :     fun myFold eq acc ([],[]) = acc
16 :     | myFold eq acc (f1::fs1,f2::fs2) =
17 :     myFold eq (eq acc (f1,f2)) (fs1,fs2)
18 :     | myFold eq acc _ = raise eqFail
19 :    
20 :     fun eqList eq = myFold (fn bool => fn fs => bool andalso eq fs) true
21 :    
22 :     fun getCtypeBindings tidtabs maps ctPair =
23 :     case ctPair
24 :     of (Void,Void) => ()
25 :     | (Ellipses,Ellipses) => ()
26 :     | (Qual (q1,ct1),Qual (q2,ct2)) =>
27 :     getCtypeBindings tidtabs maps (ct1,ct2)
28 :     | (Array (li1,ct1),Array (li2,ct2)) =>
29 :     getCtypeBindings tidtabs maps (ct1,ct2)
30 :     | (Pointer ct1,Pointer ct2) =>
31 :     getCtypeBindings tidtabs maps (ct1,ct2)
32 :     | (Function (ct1,cts1), Function (ct2,cts2)) =>
33 :     getCtypesBindings tidtabs maps (ct1::cts1,ct2::cts2)
34 :     | (EnumRef tid1,EnumRef tid2) => getTidBindings tidtabs maps (tid1,tid2)
35 :     | (StructRef tid1,StructRef tid2) => getTidBindings tidtabs maps (tid1,tid2)
36 :     | (UnionRef tid1,UnionRef tid2) => getTidBindings tidtabs maps (tid1,tid2)
37 :     | (TypeRef tid1,TypeRef tid2) => getTidBindings tidtabs maps (tid1,tid2)
38 :     | _ => ()
39 :    
40 :     and getCtypesBindings tidtabs maps ctPairs =
41 :     (map (getCtypeBindings tidtabs maps) (ListPair.zip ctPairs); ())
42 :    
43 :     and getTidBindings (tidtab1: Tables.tidtab,tidtab2: Tables.tidtab)
44 :     (maps as (tidmap,pidmap)) (tid1,tid2) =
45 :     case Tidtab.find (tidmap,tid1)
46 :     of SOME tid2' => ()
47 :     | NONE => case (Tidtab.find (tidtab1,tid1),Tidtab.find (tidtab2,tid2))
48 :     of (SOME {ntype=SOME nct1,...},SOME {ntype=SOME nct2,...}) =>
49 :     ( Tidtab.insert (tidmap,tid1,tid2)
50 :     ; getNamedCtypeBindings (tidtab1,tidtab2) maps (nct1,nct2)
51 :     )
52 :     | _ => Tidtab.insert (tidmap,tid1,tid2)
53 :    
54 :     and getNamedCtypeBindings tidtabs (maps as (tidmap,pidmap)) nctPair =
55 :     case nctPair
56 :     of (B.Struct (tid1,fields1),B.Struct (tid2,fields2)) =>
57 :     let
58 :     fun getField () ((ct1,memOpt1:Ast.member option,_)
59 :     ,(ct2,memOpt2:Ast.member option,_)) =
60 :     ( getCtypeBindings tidtabs maps (ct1,ct2)
61 :     ; case (memOpt1,memOpt2)
62 :     of (SOME {uid=pid1,...},SOME {uid=pid2,...}) =>
63 :     Pidtab.insert (pidmap,pid1,pid2)
64 :     | _ => ()
65 :     )
66 :     in
67 :     ( Tidtab.insert (tidmap,tid1,tid2)
68 :     ; myFold getField () (fields1,fields2)
69 :     )
70 :     end
71 :     | (B.Union (tid1,fields1), B.Union (tid2,fields2)) =>
72 :     let
73 :     fun getField () ((ct1,{uid=pid1,...}:Ast.member),(ct2,{uid=pid2,...}:Ast.member)) =
74 :     ( Pidtab.insert (pidmap,pid1,pid2)
75 :     ; getCtypeBindings tidtabs maps (ct1,ct2)
76 :     )
77 :     in
78 :     ( Tidtab.insert (tidmap,tid1,tid2)
79 :     ; myFold getField () (fields1,fields2)
80 :     )
81 :     end
82 :     | (B.Enum (tid1,fields1),B.Enum (tid2,fields2)) =>
83 :     let fun getField () (({uid=pid1,...}:Ast.member,_)
84 :     ,({uid=pid2,...}:Ast.member,_)) =
85 :     Pidtab.insert (pidmap,pid1,pid2)
86 :     in
87 :     ( Tidtab.insert (tidmap,tid1,tid2)
88 :     ; myFold getField () (fields1,fields2)
89 :     )
90 :     end
91 :     | (B.Typedef (tid1,ct1),B.Typedef (tid2,ct2)) =>
92 :     ( Tidtab.insert (tidmap,tid1,tid2)
93 :     ; getCtypeBindings tidtabs (tidmap,pidmap)(ct1,ct2)
94 :     )
95 :     | _ => ()
96 :    
97 :     fun eqTid tidmap (tid1,tid2) =
98 :     case Tidtab.find (tidmap,tid1)
99 :     of NONE => ( warning ("tid ("^(Tid.toString tid1)^") not found, reverting to simple equality test")
100 :     ; Tid.equal (tid1,tid2)
101 :     )
102 :     | SOME tid1' => Tid.equal (tid1',tid2)
103 :    
104 :     fun eqPid pidmap (pid1,pid2) =
105 :     case Pidtab.find (pidmap,pid1)
106 :     of NONE => ( warning ("pid ("^(Pid.toString pid1)^") not found, reverting to simple equality test")
107 :     ; Pid.equal (pid1,pid2)
108 :     )
109 :     | SOME pid1' => Pid.equal (pid1',pid2)
110 :    
111 :     fun eqMem pidmap ({uid=pid1,...}:Ast.member ,{uid=pid2, ...}:Ast.member) = eqPid pidmap (pid1,pid2)
112 :    
113 :     fun eqMemOpt pidmap (NONE,NONE) = true
114 :     | eqMemOpt pidmap (SOME mem1,SOME mem2) = eqMem pidmap (mem1,mem2)
115 :     | eqMemOpt pidmap _ = false
116 :    
117 :     fun eqCtype tidmap ctPair =
118 :     case ctPair
119 :     of (Void,Void) => true
120 :     | (Ellipses,Ellipses) => true
121 :     | (Qual (q1,ct1),Qual (q2,ct2)) =>
122 :     if q1 = q2 then eqCtype tidmap (ct1,ct2)
123 :     else false
124 :     | (Numeric quad1,Numeric quad2) => quad1 = quad2
125 :     | (Array (li1,ct1),Array (li2,ct2)) =>
126 :     if li1 = li2 then eqCtype tidmap (ct1,ct2) else false
127 :     | (Pointer ct1,Pointer ct2) => eqCtype tidmap (ct1,ct2)
128 :     | (Function (ct1,cts1), Function (ct2,cts2)) =>
129 :     eqCtypes tidmap (ct1::cts1,ct2::cts2)
130 :     | (EnumRef tid1,EnumRef tid2) => eqTid tidmap (tid1,tid2)
131 :     | (StructRef tid1,StructRef tid2) => eqTid tidmap (tid1,tid2)
132 :     | (UnionRef tid1,UnionRef tid2) => eqTid tidmap (tid1,tid2)
133 :     | (TypeRef tid1,TypeRef tid2) => eqTid tidmap (tid1,tid2)
134 :     | _ => false
135 :    
136 :     and eqCtypes tidmap = eqList (eqCtype tidmap)
137 :    
138 :     and eqNamedCtype (pair as (tidmap,pidmap)) nctPair =
139 :     case nctPair
140 :     of (B.Struct (tid1,fields1),B.Struct (tid2,fields2)) =>
141 :     let
142 :     fun eqField ((ct1,memOpt1,LIOpt1),(ct2,memOpt2,LIOpt2)) =
143 :     LIOpt1 = LIOpt2
144 :     andalso eqMemOpt pidmap (memOpt1,memOpt2)
145 :     andalso eqCtype tidmap (ct1,ct2)
146 :     val eqFields = eqList eqField
147 :     in eqTid tidmap (tid1,tid2) andalso eqFields (fields1,fields2)
148 :     end
149 :     | (B.Union (tid1,fields1),B.Union (tid2,fields2)) =>
150 :     let
151 :     fun eqField ((ct1,mem1),(ct2,mem2)) =
152 :     eqMem pidmap (mem1,mem2) andalso eqCtype tidmap (ct1,ct2)
153 :     val eqFields = eqList eqField
154 :     in eqTid tidmap (tid1,tid2) andalso eqFields (fields1,fields2)
155 :     end
156 :     | (B.Enum (tid1,fields1),B.Enum (tid2,fields2)) =>
157 :     let fun eqField ((mem1,li1),(mem2,li2)) =
158 :     li1 = li2 andalso eqMem pidmap (mem1,mem2)
159 :     val eqFields = eqList eqField
160 :     in
161 :     eqTid tidmap (tid1,tid2) andalso eqFields (fields1,fields2)
162 :     end
163 :     | (B.Typedef (tid1,ct1),B.Typedef (tid2,ct2)) =>
164 :     eqTid tidmap (tid1,tid2) andalso eqCtype tidmap (ct1,ct2)
165 :     | _ => false
166 :    
167 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0