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/trans/pequal.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/trans/pequal.sml

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

revision 586, Thu Mar 30 05:08:07 2000 UTC revision 587, Thu Mar 30 09:01:52 2000 UTC
# Line 101  Line 101 
101              in GENtyc{stamp=s,arity=arity,eq=ref(YES),              in GENtyc{stamp=s,arity=arity,eq=ref(YES),
102                        kind=DATATYPE{index=i, family=family,root=NONE,                        kind=DATATYPE{index=i, family=family,root=NONE,
103                                      stamps=stamps, freetycs=freetycs},                                      stamps=stamps, freetycs=freetycs},
104                        path=InvPath.IPATH[tycname]}                        path=InvPath.IPATH[tycname],
105                          stub = NONE}
106             end             end
107          | g (FREEtyc i) = List.nth(freetycs, i)          | g (FREEtyc i) = List.nth(freetycs, i)
108          | g x = x          | g x = x
# Line 233  Line 234 
234                     eqv                     eqv
235                 end)                 end)
236    
237          | CONty(tyc as GENtyc{kind=PRIMITIVE _,eq=ref YES,...}, tyl) =>          | CONty (tyc as GENtyc { kind, eq, stamp, arity, path, ... }, tyl) =>
238              atomeq (tyc, ty)            (case (!eq, kind) of
239                   (YES, PRIMITIVE _) => atomeq (tyc, ty)
240    
241          | CONty(GENtyc{eq=ref ABS,stamp,arity,kind,path}, tyl) =>               | (ABS,_) =>
242              test(TU.mkCONty(GENtyc{eq=ref YES,stamp=stamp,arity=arity,              test(TU.mkCONty(GENtyc{eq=ref YES,stamp=stamp,arity=arity,
243                                     kind=kind,path=path}, tyl), depth)                                        kind=kind,path=path,stub=NONE}, tyl),
244                        depth)
245              (* assume that an equality datatype has been converted              (* assume that an equality datatype has been converted
246                 to an abstract type in an abstype declaration *)                * to an abstract type in an abstype declaration *)
247    
248          | CONty(tyc as GENtyc{kind=DATATYPE{index,family as {members,...},               | (_,DATATYPE{index,family as {members,...},
249                                              freetycs,stamps,...},                             freetycs,stamps,...}) =>
                               ...}, tyl) =>  
250              let val {dcons=dcons0,...} = Vector.sub(members,index)              let val {dcons=dcons0,...} = Vector.sub(members,index)
251                  fun expandRECdcon{domain=SOME x, rep, name} =                  fun expandRECdcon{domain=SOME x, rep, name} =
252                       {domain=SOME(expandREC (family, stamps, freetycs) x),                       {domain=SOME(expandREC (family, stamps, freetycs) x),
253                        rep=rep,name=name}                        rep=rep,name=name}
254                    | expandRECdcon z = z                    | expandRECdcon z = z
255    
256               in case map expandRECdcon dcons0                 in
257                       case map expandRECdcon dcons0
258                   of [{rep=REF,...}] => atomeq(tyc, ty)                   of [{rep=REF,...}] => atomeq(tyc, ty)
259                    | dcons =>                    | dcons =>
260                       (find ty handle Notfound =>                         (find ty
261                         let val v = mkv() and x=mkv() and y=mkv()                          handle Notfound => let
262                              val v = mkv()
263                              val x=mkv()
264                              val y=mkv()
265                             val (eqv, patch) = enter ty                             val (eqv, patch) = enter ty
266                             fun inside ({name,rep,domain}, ww, uu) =                             fun inside ({name,rep,domain}, ww, uu) =
267                               (case domain                                case domain of
268                                 of NONE => trueLexp                                    NONE => trueLexp
269                                  | SOME dom =>                                  | SOME dom =>
270                                      (case reduceTy dom                                      (case reduceTy dom
271                                        of (CONty(RECORDtyc [], _)) => trueLexp                                      of (CONty(RECORDtyc [], _)) =>
272                                         | _ =>                                         trueLexp
273                                            (let val argt = argType(dom, tyl)                                       | _ => let
274                                              in APP(test(argt, depth-1),                                             val argt = argType(dom, tyl)
275                                           in
276                                               APP(test(argt, depth-1),
277                                                     RECORD[VAR ww, VAR uu])                                                     RECORD[VAR ww, VAR uu])
278                                             end)))                                         end)
279                             val lt = toLty ty                             val lt = toLty ty
280                             val argty = LT.ltc_tuple [lt,lt]                             val argty = LT.ltc_tuple [lt,lt]
281                             val pty = LT.ltc_parrow(argty, boolty)                             val pty = LT.ltc_parrow(argty, boolty)
# Line 276  Line 284 
284                               case dcons                               case dcons
285                                of [] => bug "empty data types"                                of [] => bug "empty data types"
286  (*                             | [dcon] => inside dcon       *)  (*                             | [dcon] => inside dcon       *)
287                                 | _ =>                                  | _ => let
288                                    let (** this is somewhat a hack !!!! *)                                        (* this is somewhat a hack !! *)
289                                        (* val sign = map #rep dcons *)                                        (* val sign = map #rep dcons *)
290                                        fun isConst(DA.CONSTANT _) = true                                        fun isConst(DA.CONSTANT _) =
291                                              true
292                                          | isConst(DA.LISTNIL) = true                                          | isConst(DA.LISTNIL) = true
293                                          | isConst _ = false                                          | isConst _ = false
294    
# Line 292  Line 301 
301    
302                                        fun concase dcon =                                        fun concase dcon =
303                                          let val tcs = map toTyc tyl                                          let val tcs = map toTyc tyl
304                                              val ww = mkv() and uu = mkv()                                                val ww = mkv()
305                                              val dc = transDcon(tyc,dcon,toTcLc)                                                val uu = mkv()
306                                                  val dc =
307                                                      transDcon(tyc,dcon,toTcLc)
308                                              val dconx = DATAcon(dc, tcs, ww)                                              val dconx = DATAcon(dc, tcs, ww)
309                                              val dcony = DATAcon(dc, tcs, uu)                                              val dcony = DATAcon(dc, tcs, uu)
310                                           in (dconx,                                            in
311                                                  (dconx,
312                                               SWITCH(VAR y, sign,                                               SWITCH(VAR y, sign,
313                                                [(dcony, inside(dcon,ww,uu))],                                                        [(dcony,
314                                                            inside(dcon,ww,uu))],
315                                                 SOME(falseLexp)))                                                 SOME(falseLexp)))
316                                          end                                          end
317                                     in SWITCH(VAR x, sign,                                    in
318                                          SWITCH(VAR x, sign,
319                                          map concase dcons, NONE)                                          map concase dcons, NONE)
320                                    end                                    end
321    
322                             val root = APP(PRIM(PO.PTREQL, pty, []),                             val root = APP(PRIM(PO.PTREQL, pty, []),
323                                            RECORD[VAR x, VAR y])                                            RECORD[VAR x, VAR y])
324                             val nbody = COND(root, trueLexp, body)                             val nbody = COND(root, trueLexp, body)
325                          in patch := FN(v, argty,                        in
326                              patch := FN(v, argty,
327                                       LET(x, SELECT(0, VAR v),                                       LET(x, SELECT(0, VAR v),
328                                        LET(y, SELECT(1, VAR v), nbody)));                                        LET(y, SELECT(1, VAR v), nbody)));
329                             eqv                             eqv
330                         end)                         end)
331              end              end
332                 | _ => raise Poly)
333          | _ => raise Poly)          | _ => raise Poly)
334    
335  val body = test(concreteType, 10)  val body = test(concreteType, 10)

Legend:
Removed from v.586  
changed lines
  Added in v.587

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