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-ast.sml
ViewVC logotype

Annotation of /sml/trunk/ckit/src/ast-utils/equality/eq-ast.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 EqAst (*: EQAST*) =
4 :     struct
5 :    
6 :     structure Ast = Ast
7 :     structure CT = CType
8 :     structure ECT = EqCType
9 :     structure PPL = PPLib
10 :     structure PPA = PPAst
11 :     structure EAT = EqAstExt
12 :     structure PT = Pidtab
13 :    
14 :     open Ast
15 :    
16 :     exception internalFail
17 :    
18 :     val myFold = ECT.myFold
19 :    
20 :     val trace = ref false
21 :    
22 :     fun tracer pp (ttab1,ttab2) (v1,v2) =
23 :     ( print "\nChecking: "
24 :     ; PPL.ppToStrm (pp () ttab1) TextIO.stdOut v1
25 :     ; print "\nand: "
26 :     ; PPL.ppToStrm (pp () ttab2) TextIO.stdOut v2
27 :     ; print "\n"
28 :     )
29 :    
30 :     fun PTinserts pidmap =
31 :     myFold (fn () => fn (v1,v2) => Pidtab.insert (pidmap,v1,v2)) ()
32 :    
33 :     fun TTinserts tidmap =
34 :     myFold (fn () => fn (v1,v2) => Tidtab.insert (tidmap,v1,v2)) ()
35 :    
36 :     fun eqOpt f tabs maps (NONE,NONE) = ()
37 :     | eqOpt f tabs maps (SOME v1,SOME v2) = f tabs maps (v1,v2)
38 :     | eqOpt f tabs maps _ = raise internalFail
39 :    
40 :     fun eqAst (edecls1,ttab1,edecls2,ttab2) =
41 :     let val tl1 = Tidtab.listItems ttab1
42 :     val tl2 = Tidtab.listItems ttab2
43 :     in if List.length tl1 = List.length tl2
44 :     then eqExternalDecls (ttab1,ttab2) (edecls1,edecls2)
45 :     else raise ECT.eqFail
46 :     end
47 :    
48 :     and eqExternalDecls tabs decs =
49 :     let val maps = (Tidtab.uidtab (),Pidtab.uidtab ())
50 :     in getExternalTypeBindings tabs maps decs
51 :     ; myFold (eqExternalDecl tabs) maps decs
52 :     end
53 :    
54 :     and getExternalTypeBindings tabs maps decs =
55 :     myFold (getExternalTypeBinding tabs) maps decs
56 :    
57 :     (* dpo: this needs to be fixed to declare types/functions and then check *)
58 :    
59 :     and getExternalTypeBinding tabs maps edeclPair = ()
60 :    
61 :     and eqExternalDecl tabs maps (DECL (coreDecl1,_,_),DECL (coreDecl2,_,_)) =
62 :     eqExternalCoreDecl tabs maps (coreDecl1,coreDecl2)
63 :    
64 :     and eqExternalCoreDecl (tabs as (ttab1,ttab2)) (maps as (tidmap,pidmap)) coreDeclPair =
65 :     ( if !trace then tracer PPA.ppCoreExternalDecl tabs coreDeclPair
66 :     else ()
67 :     ; case coreDeclPair
68 :     of (ExternalDecl decl1,ExternalDecl decl2) =>
69 :     eqDecl tabs maps (decl1,decl2)
70 :     | (FunctionDef (id1,ids1,stmt1),FuncDecl (id2,ids2,stmt2)) =>
71 :     let val pids1 = map (fn {uid,...} => uid) (id1::ids1)
72 :     val pids2 = map (fn {uid,...} => uid) (id2::ids2)
73 :     in PTinserts pidmap (pids1,pids2)
74 :     ; eqStmt tabs maps (stmt1,stmt2)
75 :     end
76 :     | _ => raise ECT.eqFail
77 :     )
78 :    
79 :     and eqStmt (tabs as (ttab1,ttab2)) maps (stmtPair as (STMT (coreStmt1,_,_),STMT (coreStmt2,_,_))) =
80 :     ( if !trace then tracer PPA.ppStatement tabs stmtPair else ()
81 :     ; eqCoreStmt tabs maps (coreStmt1,coreStmt2)
82 :     )
83 :     handle internalFail =>
84 :     ( print "\nThese two statements are not condidered equal:"
85 :     ; PPL.ppToStrm (PPA.ppStatement () ttab1) TextIO.stdOut (#1 stmtPair)
86 :     ; print "\nand:"
87 :     ; PPL.ppToStrm (PPA.ppStatement () ttab2) TextIO.stdOut (#2 stmtPair)
88 :     ; print "\n"
89 :     ; raise ECT.eqFail
90 :     )
91 :    
92 :     and eqDecl tabs (maps as (tidmap,pidmap)) declPair =
93 :     case declPair
94 :     of (TypeDecl tid1,TypeDecl tid2) =>
95 :     ECT.getTidBindings tabs maps (tid1,tid2)
96 :     | (VarDecl ({uid=pid1,...},initExpOpt1)
97 :     ,VarDecl ({uid=pid2,...},initExpOpt2)) =>
98 :     if eqInitExprOpt tabs maps (initExpOpt1,initExpOpt2)
99 :     then Pidtab.insert (pidmap,pid1,pid2)
100 :     else raise internalFail
101 :     | _ => raise internalFail
102 :    
103 :     and eqDecls tabs maps declsPair =
104 :     ECT.myFold
105 :     (fn () => fn declPair => eqDecl tabs maps declPair)
106 :     ()
107 :     declsPair
108 :    
109 :     and eqInitExpr tabs maps initExpPair =
110 :     case initExpPair
111 :     of (Simple exp1,Simple exp2) => eqExpr tabs maps (exp1,exp2)
112 :     | (Aggregate initExps1,Aggregate initExps2) =>
113 :     ECT.myFold
114 :     (fn () => fn iePair => eqInitExpr tabs maps iePair)
115 :     ()
116 :     (initExps1,initExps2)
117 :    
118 :     and eqInitExprOpt tabs = eqOpt eqInitExpr tabs
119 :    
120 :     and eqCoreStmt (tabs as (ttab1,ttab2)) (maps as (tidmap,pidmap)) coreStmtPair =
121 :     (case coreStmtPair
122 :     of (Expr expOpt1,Expr expOpt2) =>
123 :     if eqExpr tabs maps (expOpt1,expOpt2) then ()
124 :     else raise internalFail
125 :     | (Compound (decls1,stmts1),Compound (decls2,stmts2)) =>
126 :     ( eqDecls (ttab1,ttab2) maps (decls1,decls2)
127 :     ; eqStmts tabs maps (stmts1,stmts2)
128 :     )
129 :     | (While (exp1,stmt1),While (exp2,stmt2)) =>
130 :     if eqExpr tabs maps (exp1,exp2)
131 :     then eqStmt tabs maps (stmt1,stmt2)
132 :     else raise internalFail
133 :     | (Do (exp1,stmt1),Do (exp2,stmt2)) =>
134 :     if eqExpr tabs maps (exp1,exp2)
135 :     then eqStmt tabs maps (stmt1,stmt2)
136 :     else raise internalFail
137 :     | (For (expOpt1_1,expOpt1_2,expOpt1_3,stmt1)
138 :     ,For (expOpt2_1,expOpt2_2,expOpt2_3,stmt2)) =>
139 :     if eqExprOpt tabs maps (expOpt1_1,expOpt2_1) andalso
140 :     eqExprOpt tabs maps (expOpt1_2,expOpt2_2) andalso
141 :     eqExprOpt tabs maps (expOpt1_3,expOpt2_3)
142 :     then eqStmt tabs maps (stmt1,stmt2)
143 :     else raise internalFail
144 :     | (Labeled (pid1,stmt1),Labeled (pid2,stmt2)) =>
145 :     let val pidmap = Pidtab.insert (pidmap,pid1,pid2)
146 :     in eqStmt tabs (tidmap,pidmap) (stmt1,stmt2) end
147 :     | (CaseLabel (li1,stmt1),CaseLabel (li2,stmt2)) =>
148 :     if li1 = li2 then eqStmt tabs maps (stmt1,stmt2)
149 :     else raise internalFail
150 :     | (DefaultLabel stmt1,DefaultLabel stmt2) =>
151 :     eqStmt tabs maps (stmt1,stmt2)
152 :     | (Goto pid1,Goto pid2) =>
153 :     if ECT.eqPid pidmap (pid1,pid2) then maps
154 :     else raise internalFail
155 :     | (Break,Break) => maps
156 :     | (Continue,Continue) => maps
157 :     | (Return expOpt1,Return expOpt2) =>
158 :     if eqExprOpt tabs maps (expOpt1,expOpt2) then ()
159 :     else raise internalFail
160 :     | (IfThen (exp1,stmt1),IfThen (exp2,stmt2)) =>
161 :     if eqExpr tabs maps (exp1,exp2)
162 :     then eqStmt tabs maps (stmt1,stmt2)
163 :     else raise internalFail
164 :     | (IfThenElse (exp1,stmt1_1,stmt1_2),IfThenElse (exp2,stmt2_1,stmt2_2)) =>
165 :     if eqExpr tabs maps (exp1,exp2)
166 :     then eqStmts tabs maps ([stmt1_1,stmt1_2],[stmt2_1,stmt2_2])
167 :     else raise internalFail
168 :     | (Switch (exp1,stmt1),Switch (exp2,stmt2)) =>
169 :     if eqExpr tabs maps (exp1,exp2)
170 :     then eqStmt tabs maps (stmt1,stmt2)
171 :     else raise internalFail
172 :     | (StatExt se1,StatExt se2) => EAT.eqStatementExt tabs maps (se1,se2)
173 :     | _ => raise internalFail)
174 :    
175 :     and eqStmts tabs maps = myFold (eqStmt tabs) maps
176 :    
177 :     and eqExprOpt tabs = eqOpt eqExpr tabs
178 :    
179 :     and eqExpr (tabs as (ttab1,ttab2)) maps (expPair as (EXPR (coreExpr1,_,_),EXPR (coreExpr2,_,_))) =
180 :     ( if !trace then tracer PPA.ppExpression tabs expPair else ()
181 :     ; if eqCoreExpr tabs maps (coreExpr1,coreExpr2) then true else raise internalFail
182 :     ) handle internalFail =>
183 :     ( print "\nThese two expressions are not condidered equal:"
184 :     ; PPL.ppToStrm (PPA.ppExpression () ttab1) TextIO.stdOut (#1 expPair)
185 :     ; print "\n and"
186 :     ; PPL.ppToStrm (PPA.ppExpression () ttab2) TextIO.stdOut (#2 expPair)
187 :     ; print "\n"
188 :     ; raise ECT.eqFail
189 :     )
190 :    
191 :     and eqCoreExpr tabs (maps as (tidmap,pidmap)) coreExprPair =
192 :     case coreExprPair
193 :     of (IntConst li1,IntConst li2) => li1 = li2
194 :     | (RealConst r1,RealConst r2) => Real.== (r1,r2)
195 :     | (StringConst s1,StringConst s2) => s1=s2
196 :     | (Call (exp1,exps1),Call (exp2,exps2)) =>
197 :     eqExprs tabs maps (exp1::exps1,exp2::exps2)
198 :     | (QuestionColon (e1_1,e1_2,e1_3),QuestionColon (e2_1,e2_2,e2_3)) =>
199 :     eqExprs tabs maps ([e1_1,e1_2,e1_3],[e2_1,e2_2,e2_3])
200 :     | (Assign (e1_1,e1_2),Assign (e2_1,e2_2)) =>
201 :     eqExprs tabs maps ([e1_1,e1_2],[e2_1,e2_2])
202 :     | (Comma (e1_1,e1_2),Comma (e2_1,e2_2)) =>
203 :     eqExprs tabs maps ([e1_1,e1_2],[e2_1,e2_2])
204 :     | (Sub (e1_1,e1_2),Sub (e2_1,e2_2)) =>
205 :     eqExprs tabs maps ([e1_1,e1_2],[e2_1,e2_2])
206 :     | (Member (exp1,pid1),Member (exp2,pid2)) =>
207 :     ECT.eqPid pidmap (pid1,pid2) andalso eqExpr tabs maps (exp1,exp2)
208 :     | (Arrow (exp1,pid1),Arrow (exp2,pid2)) =>
209 :     ECT.eqPid pidmap (pid1,pid2) andalso eqExpr tabs maps (exp1,exp2)
210 :     | (Deref exp1,Deref exp2) => eqExpr tabs maps (exp1,exp2)
211 :     | (AddrOf exp1,AddrOf exp2) => eqExpr tabs maps (exp1,exp2)
212 :     | (Binop (binop1,e1_1,e1_2),Binop (binop2,e2_1,e2_2)) =>
213 :     binop1 = binop2 andalso eqExprs tabs maps ([e1_1,e1_2],[e2_1,e2_2])
214 :     | (Unop (unop1,exp1),Unop (unop2,exp2)) =>
215 :     unop1 = unop2 andalso eqExpr tabs maps (exp1,exp2)
216 :     | (Cast (ctype1,exp1),Cast (ctype2,exp2)) =>
217 :     (ECT.eqCtype tidmap (ctype1,ctype2) handle _ => false)
218 :     andalso eqExpr tabs maps (exp1,exp2)
219 :     | (Id pid1,Id pid2) =>
220 :     ECT.eqPid pidmap (pid1,pid2)
221 :     | (EnumId (pid1,li1),EnumId (pid2,li2)) =>
222 :     li1 = li2 andalso ECT.eqPid pidmap (pid1,pid2)
223 :     | (ExprExt ee1,ExprExt ee2) => EAT.eqExpressionExt tabs maps (ee1,ee2)
224 :     | (ErrorExpr,ErrorExpr) => true
225 :     | _ => raise internalFail
226 :    
227 :     and eqExprs tabs maps = ECT.eqList (eqExpr tabs maps)
228 :    
229 :     end (* structure EqAst *)

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