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/branches/SMLNJ/src/compiler/Semant/elaborate/elabtype.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/Semant/elaborate/elabtype.sml

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

revision 124, Mon Sep 7 16:19:55 1998 UTC revision 125, Mon Sep 7 18:14:32 1998 UTC
# Line 217  Line 217 
217          val _ = debugmsg ">>elabDATATYPEdec"          val _ = debugmsg ">>elabDATATYPEdec"
218          fun preprocess region (Db{tyc=name,rhs=Constrs def,tyvars,lazyp}) =          fun preprocess region (Db{tyc=name,rhs=Constrs def,tyvars,lazyp}) =
219              let val tvs = elabTyvList(tyvars,error,region)              let val tvs = elabTyvList(tyvars,error,region)
220                  val tyc = GENtyc{path=IP.extend(rpath,name),                  val strictName =
221                        if lazyp
222                        then S.tycSymbol(S.name name ^ "!")
223                        else name
224                    val tyc = GENtyc{path=IP.extend(rpath,strictName),
225                                   arity=length tyvars,                                   arity=length tyvars,
226                                   stamp=mkStamp(),                                   stamp=mkStamp(),
227                                   eq=ref DATA,kind=TEMP}                                   eq=ref DATA,kind=TEMP}
# Line 232  Line 236 
236    
237                      else tyc                      else tyc
238               in {tvs=tvs, name=name,def=def,region=region,tyc=tyc,               in {tvs=tvs, name=name,def=def,region=region,tyc=tyc,
239                   binddef=binddef,lazyp=lazyp}                   binddef=binddef,lazyp=lazyp,
240                     strictName=strictName}
241              end              end
242            | preprocess _ (MarkDb(db',region')) = preprocess region' db'            | preprocess _ (MarkDb(db',region')) = preprocess region' db'
243    
# Line 309  Line 314 
314                 | t => t                 | t => t
315    
316          (* elaborate the definition of a datatype *)          (* elaborate the definition of a datatype *)
317          fun elabRHS ({tvs,name,def,region,tyc,lazyp,binddef}, (i,done)) =          fun elabRHS ({tvs,name,def,region,tyc,lazyp,binddef,strictName},
318                         (i,done)) =
319              let val (datacons,_) =              let val (datacons,_) =
320                        elabDB((tyc,tvs,name,def,region,lazyp),fullEnv,rpath,error)                        elabDB((tyc,tvs,name,def,region,lazyp),fullEnv,rpath,error)
321                  fun mkDconDesc (DATACON{name,const,rep,sign,typ,lazyp}) =                  fun mkDconDesc (DATACON{name,const,rep,sign,typ,lazyp}) =
# Line 329  Line 335 
335                    dconDescs=map mkDconDesc datacons,                    dconDescs=map mkDconDesc datacons,
336                    tyc=tyc,                    tyc=tyc,
337                    index=i,                    index=i,
338                    lazyp=lazyp} :: done)                    lazyp=lazyp,
339                      strictName=strictName} :: done)
340              end              end
341    
342          val (_,dbs') = foldl elabRHS (0,nil) dbs          val (_,dbs') = foldl elabRHS (0,nil) dbs
# Line 337  Line 344 
344          val _ = debugmsg "--elabDATATYPEdec: RHS elaborated"          val _ = debugmsg "--elabDATATYPEdec: RHS elaborated"
345    
346          fun mkMember{name,dcons,dconDescs,tyc=GENtyc{stamp,arity,eq,...},          fun mkMember{name,dcons,dconDescs,tyc=GENtyc{stamp,arity,eq,...},
347                       dconNames,index,lazyp} =                       dconNames,index,lazyp,strictName} =
348              let val DATACON{sign,...}::_ = dcons              let val DATACON{sign,...}::_ = dcons
349                       (* extract common sign from first datacon *)                       (* extract common sign from first datacon *)
350               in (stamp, {tycname=name,dcons=dconDescs,arity=arity,               in (stamp, {tycname=strictName,dcons=dconDescs,arity=arity,
351                           eq=eq,lazyp=lazyp,sign=sign})                           eq=eq,lazyp=lazyp,sign=sign})
352              end              end
353    
# Line 359  Line 366 
366          val _ = debugmsg "--elabDATATYPEdec: members defined"          val _ = debugmsg "--elabDATATYPEdec: members defined"
367    
368          fun fixDtyc{name,index,tyc as GENtyc{path,arity,stamp,eq,kind},          fun fixDtyc{name,index,tyc as GENtyc{path,arity,stamp,eq,kind},
369                      dconNames,dcons,dconDescs,lazyp} =                      dconNames,dcons,dconDescs,lazyp,strictName} =
370              {old=tyc,              {old=tyc,
371               name=name,               name=strictName,
372               new=GENtyc{path=path,arity=arity,stamp=stamp,eq=eq,               new=GENtyc{path=path,arity=arity,stamp=stamp,eq=eq,
373                          kind=DATATYPE{index=index,                          kind=DATATYPE{index=index,
374                                        stamps=nstamps,                                        stamps=nstamps,
# Line 379  Line 386 
386          val _ = debugmsg "--elabDATATYPEdec: defineEqProps done"          val _ = debugmsg "--elabDATATYPEdec: defineEqProps done"
387    
388          fun applyMap m =          fun applyMap m =
389              let fun sameTyc(GENtyc{stamp=s1,...},GENtyc{stamp=s2,...})              let fun sameTyc(GENtyc{stamp=s1,...},GENtyc{stamp=s2,...}) =
390                                       = Stamps.eq(s1,s2)                        Stamps.eq(s1,s2)
391                    | sameTyc(tyc1 as DEFtyc _, tyc2 as DEFtyc _)                    | sameTyc(tyc1 as DEFtyc _, tyc2 as DEFtyc _) =
392                                       = equalTycon(tyc1, tyc2)                        equalTycon(tyc1, tyc2)
393                    | sameTyc _ = false                    | sameTyc _ = false
394    
395                  fun f(CONty(tyc, args)) =                  fun f(CONty(tyc, args)) =
# Line 446  Line 453 
453    
454  (*  (*
455   * $Log$   * $Log$
  *  
456   *)   *)

Legend:
Removed from v.124  
changed lines
  Added in v.125

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