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/branches/idlbasis-devel/src/MLRISC/Tools/FakeSMLAst/ast-rewrite.sml
ViewVC logotype

Annotation of /sml/branches/idlbasis-devel/src/MLRISC/Tools/FakeSMLAst/ast-rewrite.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1002 - (view) (download)

1 : leunga 744 (*
2 :     * Various translation functions
3 :     *)
4 :     functor MDLAstRewriter(Ast : MDL_AST) : MDL_AST_REWRITER =
5 :     struct
6 :    
7 :     structure Ast = Ast
8 : leunga 775 structure Error = MDLError
9 : leunga 744
10 :     type 'a rewriter = ('a -> 'a) -> ('a -> 'a)
11 :    
12 :     type clients = {exp : Ast.exp rewriter,
13 :     decl : Ast.decl rewriter,
14 :     sexp : Ast.structexp rewriter,
15 :     pat : Ast.pat rewriter,
16 :     ty : Ast.ty rewriter
17 :     }
18 :     type trans = {exp : Ast.exp -> Ast.exp,
19 :     decl : Ast.decl -> Ast.decl,
20 :     sexp : Ast.structexp -> Ast.structexp,
21 :     pat : Ast.pat -> Ast.pat,
22 :     ty : Ast.ty -> Ast.ty
23 :     }
24 :    
25 :     open Ast
26 :    
27 :     fun noRewrite f e = e
28 :    
29 :     fun opt f NONE = NONE
30 :     | opt f (SOME e) = SOME(f e)
31 :    
32 :     fun rewrite{exp=rwExp, decl=rwDecl, pat=rwPat, sexp=rwSexp, ty=rwTy} =
33 :     let fun exp e =
34 :     let val e = case e of
35 :     CONSexp(id,SOME e) => CONSexp(id,SOME(exp e))
36 :     | LISTexp(es,e) => LISTexp(map exp es,opt exp e)
37 :     | TUPLEexp es => TUPLEexp(map exp es)
38 :     | RECORDexp es => RECORDexp(map (fn (l,e) => (l,exp e)) es)
39 :     | SEQexp es => SEQexp(map exp es)
40 :     | APPexp(f,x) => APPexp(exp f, exp x)
41 :     | IFexp(x,y,z) => IFexp(exp x, exp y, exp z)
42 :     | RAISEexp e => RAISEexp(exp e)
43 :     | HANDLEexp(e,c) => HANDLEexp(exp e,map clause c)
44 :     | CASEexp(e,c) => CASEexp(exp e,map clause c)
45 :     | LAMBDAexp c => LAMBDAexp(map clause c)
46 :     | LETexp(d,e) => LETexp(map decl d,map exp e)
47 :     | TYPEDexp(e,t) => TYPEDexp(exp e,ty t)
48 : leunga 775 | MARKexp(l,e) => (Error.setLoc l; MARKexp(l,exp e))
49 : leunga 744 | LOCexp(id,e,region) => LOCexp(id,exp e,region)
50 :     | BITSLICEexp(e,slices) => BITSLICEexp(exp e,slices)
51 :     | TYPEexp t => TYPEexp(ty t)
52 : leunga 775 | CONTexp(e,x) => CONTexp(exp e,x)
53 : leunga 744 | e => e
54 :     in rwExp exp e end
55 :    
56 :     and decl d =
57 :     let val d = case d of
58 :     DATATYPEdecl(dbs,tbs) => DATATYPEdecl(map dbind dbs,map tbind tbs)
59 :     | FUNdecl(fbs) => FUNdecl(map fbind fbs)
60 :     | RTLdecl(p,e,l) => RTLdecl(pat p,exp e,l)
61 :     | RTLSIGdecl(id,t) => RTLSIGdecl(id,ty t)
62 :     | VALdecl(vbs) => VALdecl(map vbind vbs)
63 :     | VALSIGdecl(id,t) => VALSIGdecl(id,ty t)
64 :     | TYPESIGdecl(id,tvs) => TYPESIGdecl(id,tvs)
65 :     | LOCALdecl(d1,d2) => LOCALdecl(map decl d1,map decl d2)
66 :     | SEQdecl ds => SEQdecl(map decl ds)
67 :     | STRUCTUREdecl(id,ds,s,se) =>
68 : blume 1002 STRUCTUREdecl(id,map decl ds,sigconopt s,sexp se)
69 : leunga 775 | FUNCTORdecl(id,ds,s,se) =>
70 : blume 1002 FUNCTORdecl(id, map decl ds,sigconopt s, sexp se)
71 : leunga 775 | INCLUDESIGdecl s => INCLUDESIGdecl(sigexp s)
72 : leunga 744 | SIGNATUREdecl(id,s) => SIGNATUREdecl(id, sigexp s)
73 :     | STRUCTURESIGdecl(id,s) => STRUCTURESIGdecl(id, sigexp s)
74 :     | OPENdecl ids => OPENdecl ids
75 : blume 1002 | FUNCTORARGdecl(id,se) => FUNCTORARGdecl(id,sigcon se)
76 : leunga 775 | EXCEPTIONdecl ebs => EXCEPTIONdecl(map ebind ebs)
77 :     | MARKdecl(l,d) => (Error.setLoc l; MARKdecl(l,decl d))
78 : leunga 744 | d => d
79 :     in rwDecl decl d end
80 :    
81 : blume 1002 and sigcon{abstract,sigexp=se} = {abstract=abstract,sigexp=sigexp se}
82 :    
83 :     and sigconopt s = Option.map sigcon s
84 :    
85 : leunga 775 and ebind(b as EXCEPTIONbind(id,NONE)) = b
86 :     | ebind(EXCEPTIONbind(id,SOME t)) = EXCEPTIONbind(id,SOME(ty t))
87 :     | ebind(b as EXCEPTIONEQbind _) = b
88 :    
89 : leunga 744 and sigexp se =
90 :     let val se = case se of
91 :     IDsig _ => se
92 :     | WHEREsig(se,ident,s) =>
93 :     WHEREsig(sigexp se,ident,sexp s)
94 :     | WHERETYPEsig(se,ident,t) =>
95 :     WHERETYPEsig(sigexp se,ident,ty t)
96 :     | DECLsig ds => DECLsig(map decl ds)
97 :     in se end
98 :    
99 :     and sexp se =
100 :     let val se = case se of
101 : leunga 775 APPsexp(a,se) => APPsexp(sexp a,sexp se)
102 : leunga 744 | DECLsexp ds => DECLsexp(map decl ds)
103 :     | CONSTRAINEDsexp(s, si) => CONSTRAINEDsexp(sexp s,sigexp si)
104 :     | IDsexp _ => se
105 :     in rwSexp sexp se end
106 :    
107 :     and ty t =
108 :     let val t = case t of
109 :     IDty _ => t
110 :     | TYVARty _ => t
111 :     | INTVARty _ => t
112 :     | VARty(_,_,_,ref(SOME t)) => ty t
113 :     | VARty(_,_,_,ref NONE) => t
114 :     | APPty(f, ts) => APPty(f, map ty ts)
115 :     | FUNty(a,b) => FUNty(ty a, ty b)
116 :     | TUPLEty ts => TUPLEty(map ty ts)
117 :     | RECORDty lts => RECORDty(map (fn (l,t) => (l,ty t)) lts)
118 :     | POLYty(ts,t) => POLYty(map ty ts, ty t)
119 :     | LAMBDAty(ts, t) => LAMBDAty(map ty ts, ty t)
120 :     | CELLty _ => t
121 :     in rwTy ty t end
122 :    
123 :     and pat p =
124 :     let val p = case p of
125 :     IDpat id => p
126 :     | WILDpat => p
127 :     | ASpat(id,p) => ASpat(id, pat p)
128 :     | LITpat l => p
129 :     | LISTpat(ps,p) => LISTpat(map pat ps,opt pat p)
130 :     | TUPLEpat ps => TUPLEpat(map pat ps)
131 :     | RECORDpat(lps,flex) =>
132 :     RECORDpat(map (fn (l,p) => (l,pat p)) lps, flex)
133 : blume 1002 | TYPEDpat(p,t) => TYPEDpat(pat p,ty t)
134 : leunga 744 | CONSpat(id,NONE) => p
135 :     | CONSpat(id,SOME p) => CONSpat(id,SOME(pat p))
136 :     | ORpat ps => ORpat(map pat ps)
137 : leunga 775 | ANDpat ps => ANDpat(map pat ps)
138 :     | NOTpat p => NOTpat(pat p)
139 :     | WHEREpat(p,e) => WHEREpat(pat p,exp e)
140 :     | NESTEDpat(p,e,p') => NESTEDpat(pat p,exp e,pat p')
141 : leunga 744 in rwPat pat p end
142 :    
143 :     and fbind(FUNbind(id,c)) = FUNbind(id,map clause c)
144 :    
145 :     and clause(CLAUSE(ps,g,e)) = CLAUSE(map pat ps,guard g,exp e)
146 :    
147 :     and guard NONE = NONE
148 :     | guard (SOME e) = SOME(exp e)
149 :    
150 :     and vbind(VALbind(p,e)) = VALbind(pat p,exp e)
151 :    
152 :     and dbind db = db
153 :    
154 :     and tbind tb = tb
155 :     in { pat=pat,
156 :     exp=exp,
157 :     decl=decl,
158 :     sexp=sexp,
159 :     ty=ty
160 :     }
161 :     end
162 :     end

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