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 775 - (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 : 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 :     STRUCTUREdecl(id,map decl ds,s, sexp se)
69 : leunga 775 | FUNCTORdecl(id,ds,s,se) =>
70 :     FUNCTORdecl(id, map decl ds,s, sexp se)
71 :     | 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 :     | FUNCTORARGdecl(id,se) => FUNCTORARGdecl(id, sigexp 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 : leunga 775 and ebind(b as EXCEPTIONbind(id,NONE)) = b
82 :     | ebind(EXCEPTIONbind(id,SOME t)) = EXCEPTIONbind(id,SOME(ty t))
83 :     | ebind(b as EXCEPTIONEQbind _) = b
84 :    
85 : leunga 744 and sigexp se =
86 :     let val se = case se of
87 :     IDsig _ => se
88 :     | WHEREsig(se,ident,s) =>
89 :     WHEREsig(sigexp se,ident,sexp s)
90 :     | WHERETYPEsig(se,ident,t) =>
91 :     WHERETYPEsig(sigexp se,ident,ty t)
92 :     | DECLsig ds => DECLsig(map decl ds)
93 :     in se end
94 :    
95 :     and sexp se =
96 :     let val se = case se of
97 : leunga 775 APPsexp(a,se) => APPsexp(sexp a,sexp se)
98 : leunga 744 | DECLsexp ds => DECLsexp(map decl ds)
99 :     | CONSTRAINEDsexp(s, si) => CONSTRAINEDsexp(sexp s,sigexp si)
100 :     | IDsexp _ => se
101 :     in rwSexp sexp se end
102 :    
103 :     and ty t =
104 :     let val t = case t of
105 :     IDty _ => t
106 :     | TYVARty _ => t
107 :     | INTVARty _ => t
108 :     | VARty(_,_,_,ref(SOME t)) => ty t
109 :     | VARty(_,_,_,ref NONE) => t
110 :     | APPty(f, ts) => APPty(f, map ty ts)
111 :     | FUNty(a,b) => FUNty(ty a, ty b)
112 :     | TUPLEty ts => TUPLEty(map ty ts)
113 :     | RECORDty lts => RECORDty(map (fn (l,t) => (l,ty t)) lts)
114 :     | POLYty(ts,t) => POLYty(map ty ts, ty t)
115 :     | LAMBDAty(ts, t) => LAMBDAty(map ty ts, ty t)
116 :     | CELLty _ => t
117 :     in rwTy ty t end
118 :    
119 :     and pat p =
120 :     let val p = case p of
121 :     IDpat id => p
122 :     | WILDpat => p
123 :     | ASpat(id,p) => ASpat(id, pat p)
124 :     | LITpat l => p
125 :     | LISTpat(ps,p) => LISTpat(map pat ps,opt pat p)
126 :     | TUPLEpat ps => TUPLEpat(map pat ps)
127 :     | RECORDpat(lps,flex) =>
128 :     RECORDpat(map (fn (l,p) => (l,pat p)) lps, flex)
129 :     | CONSpat(id,NONE) => p
130 :     | CONSpat(id,SOME p) => CONSpat(id,SOME(pat p))
131 :     | ORpat ps => ORpat(map pat ps)
132 : leunga 775 | ANDpat ps => ANDpat(map pat ps)
133 :     | NOTpat p => NOTpat(pat p)
134 :     | WHEREpat(p,e) => WHEREpat(pat p,exp e)
135 :     | NESTEDpat(p,e,p') => NESTEDpat(pat p,exp e,pat p')
136 : leunga 744 in rwPat pat p end
137 :    
138 :     and fbind(FUNbind(id,c)) = FUNbind(id,map clause c)
139 :    
140 :     and clause(CLAUSE(ps,g,e)) = CLAUSE(map pat ps,guard g,exp e)
141 :    
142 :     and guard NONE = NONE
143 :     | guard (SOME e) = SOME(exp e)
144 :    
145 :     and vbind(VALbind(p,e)) = VALbind(pat p,exp e)
146 :    
147 :     and dbind db = db
148 :    
149 :     and tbind tb = tb
150 :     in { pat=pat,
151 :     exp=exp,
152 :     decl=decl,
153 :     sexp=sexp,
154 :     ty=ty
155 :     }
156 :     end
157 :     end

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