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

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/flint/flintutil.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/flint/flintutil.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 154, Sun Oct 11 22:22:47 1998 UTC revision 197, Sun Nov 22 01:25:23 1998 UTC
# Line 20  Line 20 
20    
21    (* copy a lexp with alpha renaming.    (* copy a lexp with alpha renaming.
22     * free variables remain unchanged except for the renaming specified     * free variables remain unchanged except for the renaming specified
23     * in the first argument *)     * in the first (types) and second (values) argument *)
24    val copy : FLINT.lvar IntmapF.intmap -> FLINT.lexp -> FLINT.lexp    val copy : (FLINT.tvar * FLINT.tyc) list ->
25                 FLINT.lvar IntmapF.intmap ->
26                 FLINT.lexp -> FLINT.lexp
27    
28    val dcon_eq : FLINT.dcon * FLINT.dcon -> bool    val dcon_eq : FLINT.dcon * FLINT.dcon -> bool
29    
# Line 36  Line 38 
38        structure PO = PrimOp        structure PO = PrimOp
39        structure DA = Access        structure DA = Access
40        structure M  = IntmapF        structure M  = IntmapF
41          structure A  = Access
42          structure O  = Option
43        open FLINT        open FLINT
44  in  in
45    
# Line 89  Line 93 
93   * except for the renaming specified in the first argument.   * except for the renaming specified in the first argument.
94   *   val copy: lvar M.intmap -> fundec -> fundec   *   val copy: lvar M.intmap -> fundec -> fundec
95   *)   *)
96  fun copy alpha le = let  fun copy ta alpha le = let
97      fun substvar lv = ((M.lookup alpha lv) handle M.IntmapF => lv)  
98      fun substval (VAR lv) = VAR(substvar lv)      val tc_subst = LT.tc_nvar_subst_gen()
99        | substval v = v      val lt_subst = LT.lt_nvar_subst_gen()
100    
101        fun substvar alpha lv = ((M.lookup alpha lv) handle M.IntmapF => lv)
102        fun substval alpha (VAR lv) = VAR(substvar alpha lv)
103          | substval alpha v = v
104      fun newv (lv,alpha) =      fun newv (lv,alpha) =
105          let val nlv = cplv lv in (nlv, M.add(alpha,lv,nlv)) end          let val nlv = cplv lv in (nlv, M.add(alpha,lv,nlv)) end
106      fun newvs (lvs,alpha) =      fun newvs (lvs,alpha) =
107          foldr (fn (lv,(lvs,alpha)) =>          foldr (fn (lv,(lvs,alpha)) =>
108                 let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)                 let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)
109                ([],alpha) lvs                ([],alpha) lvs
110      fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =      fun cdcon ta alpha (s,ac,lty) =
111          (s, Access.EXN(Access.LVAR(substvar lv)), lty)          (s,
112        | cdcon dc = dc           case ac
113      fun cpo (SOME{default,table},po,lty,tycs) =            of A.EXN(A.LVAR lv) => A.EXN(A.LVAR(substvar alpha lv))
114          (SOME{default=substvar default,             | _ => ac,
115                table=map (fn (tycs,lv) => (tycs, substvar lv)) table},           lt_subst ta lty)
116           po,lty,tycs)      fun cpo ta alpha (dict,po,lty,tycs) =
117        | cpo po = po          (O.map (fn {default,table} =>
118                    {default=substvar alpha default,
119                     table=map (fn (tycs,lv) =>
120                                (map (tc_subst ta) tycs, substvar alpha lv))
121                               table}) dict,
122             po, lt_subst ta lty, map (tc_subst ta) tycs)
123        fun cfk ta {isrec=SOME(ltys,lk),known,inline,cconv} =
124            {isrec=SOME(map (lt_subst ta) ltys,lk),
125             known=known, inline=inline, cconv=cconv}
126          | cfk _ fk = fk
127    
128        fun crk ta (RK_VECTOR tyc) = RK_VECTOR(tc_subst ta tyc)
129          | crk _ rk = rk
130    
131        fun copy' ta alpha le = let
132            val cpo = cpo ta alpha
133            val cdcon = cdcon ta alpha
134            val substvar = substvar alpha
135            val substval = substval alpha
136            val copy = copy' ta
137  in case le  in case le
138      of RET vs => RET(map substval vs)      of RET vs => RET(map substval vs)
139       | LET (lvs,le,body) =>       | LET (lvs,le,body) =>
# Line 117  Line 144 
144       | FIX (fdecs,le) =>       | FIX (fdecs,le) =>
145         let fun cfun alpha ((fk,f,args,body):fundec,nf) =         let fun cfun alpha ((fk,f,args,body):fundec,nf) =
146                 let val (nargs,nalpha) = newvs(map #1 args, alpha)                 let val (nargs,nalpha) = newvs(map #1 args, alpha)
147                 in (fk, nf, ListPair.zip(nargs, (map #2 args)), copy nalpha body)                 in (cfk ta fk, nf,
148                       ListPair.zip(nargs, (map (lt_subst ta o #2) args)),
149                       copy nalpha body)
150                 end                 end
151             val (nfs, nalpha) = newvs(map #2 fdecs, alpha)             val (nfs, nalpha) = newvs(map #2 fdecs, alpha)
152             val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)             val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)
# Line 129  Line 158 
158         (* don't forget to rename the tvar also *)         (* don't forget to rename the tvar also *)
159         let val (nlv,nalpha) = newv(lv,alpha)         let val (nlv,nalpha) = newv(lv,alpha)
160             val (nargs,ialpha) = newvs(map #1 args, nalpha)             val (nargs,ialpha) = newvs(map #1 args, nalpha)
161         in TFN((nlv, ListPair.zip(nargs, map #2 args), copy ialpha body),             val ita = (ListPair.map (fn (t,nt) => (t, LT.tcc_nvar nt))
162                                       (map #1 args, nargs)) @ ta
163           in TFN((nlv, ListPair.zip(nargs, map #2 args), copy' ita ialpha body),
164                  copy nalpha le)                  copy nalpha le)
165         end         end
166       | TAPP (f,tycs) => TAPP(substval f, tycs)       | TAPP (f,tycs) => TAPP(substval f, map (tc_subst ta) tycs)
167       | SWITCH (v,ac,arms,def) =>       | SWITCH (v,ac,arms,def) =>
168         let fun carm (DATAcon(dc,tycs,lv),le) =         let fun carm (DATAcon(dc,tycs,lv),le) =
169                 let val (nlv,nalpha) = newv(lv, alpha)                 let val (nlv,nalpha) = newv(lv, alpha)
170                 in (DATAcon(cdcon dc, tycs, nlv), copy nalpha le)                 in (DATAcon(cdcon dc, map (tc_subst ta) tycs, nlv),
171                       copy nalpha le)
172                 end                 end
173               | carm (con,le) = (con, copy alpha le)               | carm (con,le) = (con, copy alpha le)
174         in SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)         in SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
175         end         end
176       | CON (dc,tycs,v,lv,le) =>       | CON (dc,tycs,v,lv,le) =>
177         let val (nlv,nalpha) = newv(lv, alpha)         let val (nlv,nalpha) = newv(lv, alpha)
178         in CON(cdcon dc, tycs, substval v, nlv, copy nalpha le)         in CON(cdcon dc, map (tc_subst ta) tycs, substval v, nlv, copy nalpha le)
179         end         end
180       | RECORD (rk,vs,lv,le) =>       | RECORD (rk,vs,lv,le) =>
181         let val (nlv,nalpha) = newv(lv, alpha)         let val (nlv,nalpha) = newv(lv, alpha)
182         in RECORD(rk, map substval vs, nlv, copy nalpha le)         in RECORD(crk ta rk, map substval vs, nlv, copy nalpha le)
183         end         end
184       | SELECT (v,i,lv,le) =>       | SELECT (v,i,lv,le) =>
185         let val (nlv,nalpha) = newv(lv, alpha)         let val (nlv,nalpha) = newv(lv, alpha)
186         in SELECT(substval v, i, nlv, copy nalpha le)         in SELECT(substval v, i, nlv, copy nalpha le)
187         end         end
188       | RAISE (v,ltys) => RAISE(substval v, ltys)       | RAISE (v,ltys) => RAISE(substval v, map (lt_subst ta) ltys)
189       | HANDLE (le,v) => HANDLE(copy alpha le, substval v)       | HANDLE (le,v) => HANDLE(copy alpha le, substval v)
190       | BRANCH (po,vs,le1,le2) =>       | BRANCH (po,vs,le1,le2) =>
191         BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)         BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
# Line 162  Line 194 
194         in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)         in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
195         end         end
196  end  end
197    in copy' ta alpha le
198    end
199    
200    
201  end (* top-level local *)  end (* top-level local *)

Legend:
Removed from v.154  
changed lines
  Added in v.197

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