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 744 - (view) (download)
Original Path: sml/trunk/src/MLRISC/Tools/FakeSMLAst/ast-rewrite.sml

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

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