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/primop-branch-3/compiler/FLINT/trans/reptycprops.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/FLINT/trans/reptycprops.sml

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

revision 3292, Mon Apr 20 20:35:09 2009 UTC revision 3293, Tue Apr 21 02:35:49 2009 UTC
# Line 1  Line 1 
1  (* reptycprops.sml  (* reptycprops.sml
2    
3     This module preprocesses the absyn for Translate. It fills in tycpath     This module processes the static information (realizations and signatures)
4     and sigBoundeps information.     to obtain primary type component information for Translate. It fills in
5       tycpath and sigBoundeps information.
6    
7     sigBoundeps is a list of the representative entities for a signature     sigBoundeps is a list of the representative entities for a signature
8     This is used to determine which tycs in a functor parameter are     This is used to determine which tycs in a functor parameter are
# Line 19  Line 20 
20    
21  signature REPTYCPROPS =  signature REPTYCPROPS =
22  sig  sig
    val procDec : Absyn.dec * DebIndex.index  
                  -> (AbsynTP.dec * TypesTP.tycpath FlexTycMap.map)  
23     val getTk : Modules.fctSig * Modules.strEntity * Modules.strEntity     val getTk : Modules.fctSig * Modules.strEntity * Modules.strEntity
24                 * DebIndex.depth                 * DebIndex.depth
25                 -> (TypesTP.tycpath list * TypesTP.tycpath FlexTycMap.map)                 -> (TypesTP.tycpath list * TypesTP.tycpath FlexTycMap.map)
# Line 46  Line 45 
45        structure LT = LtyExtern        structure LT = LtyExtern
46        structure TU = TypesUtil        structure TU = TypesUtil
47        structure S = Symbol        structure S = Symbol
48        structure AT = AbsynTP  (*      structure AT = AbsynTP *)
49        structure V = VarCon        structure V = VarCon
50        structure FTM = FlexTycMap        structure FTM = FlexTycMap
51    
# Line 691  Line 690 
690            | getTk _ = bug "getTk 0"            | getTk _ = bug "getTk 0"
691    
692      end (* local *)      end (* local *)
   
     fun procCloSE(se) =  
         (debugmsg "--procCloSE";  
          case se  
           of M.VARstr _ => se  
            | M.CONSTstr _ => se  
            | M.STRUCTURE _ => se  
            | M.APPLY(fctExp, strExp) =>  
              M.APPLY(procCloFE fctExp, procCloSE strExp)  
            | M.LETstr(entDec, strExp) =>  
              M.LETstr(entDec, procCloSE strExp)  
            | M.ABSstr(sign, strExp) =>  
              M.ABSstr(sign, procCloSE strExp)  
            | M.CONSTRAINstr{boundvar,raw,coercion} =>  
              M.CONSTRAINstr{boundvar=boundvar,raw=raw,  
                             coercion=procCloSE coercion}  
            | M.FORMstr(M.FSIG _) => se  
            | M.FORMstr(M.ERRORfsig) => bug "unexpected FORMstr in procCloSE")  
   
     and procCloFE(fe) =  
         (debugmsg "--procCloFE";  
          case fe  
           of M.VARfct _ => fe  
            | M.CONSTfct _ => fe  
            | M.LAMBDA{body,param,paramRlzn} =>  
              M.LAMBDA{param=param, body=procCloSE body, paramRlzn=paramRlzn}  
            | M.LETfct(entDec, fexp) => M.LETfct(entDec, procCloFE fexp))  
   
     (* dec * DebIndex.depth ->  
              dec with tycpaths and memoized ep * tkind lists  
        This code needs EPMap (don't forgot EPMap in the local ... in  
        bindings section above ...)  
      *)  
     fun procDec' (ftmap, dec, d : DI.depth) =  
         let  
             val _ = debugmsg (">>procDec "^DI.dp_print d)  
             fun procStrexp (ftmap, def, d : DI.depth) =  
                 (debugmsg (">>procStrexp d="^DI.dp_print d);  
                 (case def  
                   of (APPstr{oper=oper  
                               as M.FCT{sign=fctsign  
                                         as M.FSIG {paramsig=fsparsig  
                                                         as M.SIG fsr,  
                                                    bodysig as M.SIG bfsr, ...},  
                                        rlzn=fctRlzn,access,prim},  
                              arg=arg  
                                 as M.STR{sign=argsig  
                                             as M.SIG{elements,...},  
                         rlzn=argRlzn as {entities,...},...}, ...}) =>  
                      let val {paramRlzn=dummyRlzn,  
                               bodyRlzn, (* DELETED *)  
                               closure=M.CLOSURE{body,param=fclparam,  
                                                 env=fclenv},  
                               stamp=fstmp,  
                               properties=fprops,  
                               rpath=frp,  
                               stub=fstub} =  
                              fctRlzn  
                          val dummyEnts = #entities dummyRlzn  
                          val _ = debugmsg "--strBinds APPstr"  
                          val _ = if !debugging then  
                                      (debugmsg "===fsparsig===";  
                                      ppSig fsparsig;  
                                      debugmsg "\n===dummyEnts===";  
                                      ppEntities dummyEnts;  
                                      debugmsg "===argsig===\n";  
                                      ppSig argsig;  
                                      debugmsg "\n===argEnts===";  
                                      ppEntities entities;  
                                      debugmsg "\n===bodysig===\n";  
                                      ppSig bodysig;  
                                      debugmsg "===bodyRlzn===\n";  
                                      ppEnt (M.STRent bodyRlzn))  (* DELETED *)  
                                  else ()  
                          val _ = debugmsg "--procStrexp[APPstr] param/arg"  
                          val (ftmap', argtycs') =  
                              primaryCompInStruct(ftmap, dummyRlzn, argRlzn,  
                                                  fsparsig, d)  
   
                          val _ = debugmsg "--procStrexp[APPstr] body"  
   
                          (* [TODO] This is where the bodyRlzn's references  
                             to the free instantiation should be replaced  
                             by references to the argRlzn.  
                           *)  
                   (* BOGUS! bodyRlzn is going away *)  
                          val(ftmap2, _) =  
                             primaryCompInStruct(ftmap', bodyRlzn, bodyRlzn,  
                                                 bodysig, d)  
                          val _ = debugmsg "--procStrexp[APPstr] body done"  
                          val body' = procCloSE(body)  
                          val fcl' =  
                              M.CLOSURE{param=fclparam,  
                                        env=fclenv,  
                                        body=body'}  
                          val fctRlzn' =  
                              {paramRlzn=dummyRlzn,  
                               bodyRlzn=Modules.bogusStrEntity, (* DELETE *)  
                               stamp=fstmp,  
                               properties=fprops,  
                               rpath=frp,  
                               stub=fstub,  
                               closure=fcl'}  
                          val oper' =  
                              M.FCT{sign=fctsign,  
                                    access=access,  
                                    prim=prim,  
                                    rlzn=fctRlzn'}  
                          (* getTycPaths(fsparsig, dummyEnts) *)  
                          val se' = AT.APPstr {oper=oper', arg=arg,  
                                               argtycs=argtycs'}  
                      (* Check that argtycs = argtycs' here *)  
                      (* val _ = if checkTycPaths(argtycs, argtycs')  
                                    orelse (not (!printStrFct))  
                                 then ()  
                                 else (print "\nrepEPs:\n";  
                                       app ppEP eps;  
                                       print "\nfsparsig:\n";  
                                       ppSig fsparsig;  
                                       print "\nargsig:\n";  
                                       ppSig argsig;  
                                       print "\nfctRlzn:\n";  
                                       ppEnt (M.FCTent fctRlzn);  
                                       print "\nargRlzn:\n";  
                                       ppEnt (M.STRent argRlzn);  
                                       print "\ndummyEnts:\n";  
                                       ppEntities dummyEnts;  
                                       bug "Wrong arg tycs")  *)  
                      (* val _ = if length argtycs <> length argtycs'  
                                 then bug "strBinds: bad argtycs computation"  
                                 else ()  *)  
                      in (se', unionMaps[ftmap, ftmap2])  
                      end  
                    | APPstr {oper=M.FCT _, arg=M.STRSIG _, ...} =>  
                      bug "strBinds: Unimplemented"  
                    | LETstr(dec,se') =>  
                      let val (dec',ftmap1) = procDec'(ftmap, dec,d)  
                          val (se'',ftmap2) = procStrexp (ftmap1, se',d)  
                      in  
                          (AT.LETstr(dec', se''), ftmap2)  
                      end  
                    | VARstr s => (AT.VARstr s, ftmap)  
                    | MARKstr(se',r) =>  
                      let val (se'', ftmap1) = procStrexp (ftmap, se',d)  
                      in  
                          (AT.MARKstr(se'', r), ftmap1)  
                      end  
                    | STRstr binds => (AT.STRstr binds, ftmap)  
                    | _ => bug "procStrexp"))  
   
             fun fctBinds(ftmap, [], d) = ([], ftmap)  
               | fctBinds(ftmap,  
                          (b as FCTB{fct=fct  
                                 as M.FCT{sign=M.FSIG{paramsig=paramsig'  
                         as M.SIG fsr,paramvar,bodysig,...},  
                         rlzn={paramRlzn,bodyRlzn (* DELETE *),...}, ...}, def, name})::rest,  
                          d) =  
                 let val _ = debugmsg ("--fctBinds d="^DI.dp_print d)  
                     val paramEnts = #entities paramRlzn  
                     fun mkFctexp(ftmap, fe) =  
                         (debugmsg ("--mkFctexp");  
                          (case fe  
                           of VARfct f =>  
                              (AT.VARfct f, ftmap)  
                            | FCTfct{param=param  
                                       as M.STR{sign=paramsig  
                                                 as M.SIG sr,  
                                                rlzn=rlzn  
                                                 as {entities,  
                                                     ...},  
                                                access, prim},  
                                     def} =>  
                              (debugmsg (">>fctBinds:mkFctexp[FCTfct] name "^  
                                         S.name name);  
                               let  
                                   val _ = if !debugging  
                                           then (print "--fctBinds[FCTfct] paramsig'\n";  
                                                 ppSig paramsig';  
                                                 print "\n--fctBinds[FCTfct] paramsig\n";  
                                                 ppSig paramsig;  
                                                 print "\n--fctBinds[FCTfct] paramEnts\n";  
                                                 ppEntities paramEnts;  
                                                 print "\n--fctBinds[FCTfct] rlznEntities\n";  
                                                 ppEntities entities)  
                                           else ()  
   
                                   val (ftmap1, argtycs') =  
                                       primaryCompInStruct(ftmap, rlzn, rlzn,  
                                                           paramsig', d)  
                                   (* What is the difference between sr  
                                      and fsr? *)  
                                   val (def',ftmap2) =  
                                       procStrexp (unionMaps [ftmap, ftmap1],  
                                                   def, DI.next d)  
   
                               in (AT.FCTfct{param=param, def=def',  
                                            argtycs=argtycs'},  
                                   ftmap2)  
                               end)  
                            | MARKfct(fe',region) =>  
                              let val (fe'',ftmap1) = mkFctexp(ftmap, fe')  
                              in (AT.MARKfct(fe'',region), ftmap1)  
                              end  
                            | LETfct(dec', fe') =>  
                              let val (dec'',ftmap1) = procDec'(ftmap, dec',d)  
                                  val (fe', ftmap2) = mkFctexp (ftmap1, fe')  
                              in (AT.LETfct(dec'', fe'), ftmap2)  
                              end  
                            | _ => bug "mkFctexp 0"))  
                     val (def', ftmap1) = mkFctexp(ftmap, def)  
                     val (binds,ftmap2) =  fctBinds(ftmap1, rest, d)  
                 in (AT.FCTB{name=name, fct=fct, def=def'} :: binds,  
                     ftmap2)  
                 end  
               | fctBinds _ = bug "fctBinds: unexpected binding"  
   
             fun strBinds(ftmap, []) = ([], ftmap)  
               | strBinds(ftmap, (b as STRB{name, str, def})::rest) =  
                 let val _ = debugmsg (">>strBinds "^  
                                       Symbol.symbolToString name)  
                     val (def', ftmap1) = procStrexp(ftmap, def, d)  
                     val sb' = AT.STRB{name=name, str=str, def=def'}  
                     val (strbs, ftmap2) = strBinds(ftmap1,rest)  
                 in  
                     (sb' :: strbs, ftmap2)  
                 end (* fun strBinds *)  
   
             fun transVB(VB {pat,exp,boundtvs,tyvars}) =  
                 AT.VB{pat=pat,exp= #1 (transExp ftmap d exp),boundtvs=boundtvs,  
                       tyvars=tyvars}  
             fun transRVB(RVB{var,exp,boundtvs,resultty,tyvars}) =  
                 AT.RVB{var=var,exp= #1 (transExp ftmap d exp),boundtvs=boundtvs,  
                        resultty=resultty,tyvars=tyvars}  
         in  
             (case dec  
               of SEQdec(decs) =>  
                  let val (decs',ftmap1) =  
                          foldl (fn(dec', (decs, ftmap')) =>  
                                   let val (dec'', ftmap'') =  
                                           procDec'(ftmap', dec',d)  
                                   in (dec''::decs, ftmap'')  
                                   end) ([], ftmap) decs  
                  in  
                      (AT.SEQdec(rev decs'), ftmap1)  
                  end  
                | LOCALdec(dec1, dec2) =>  
                  let val (dec1',ftmap1) = procDec'(ftmap, dec1,d)  
                      val (dec2',ftmap2) = procDec'(ftmap1, dec2,d)  
                  in (AT.LOCALdec(dec1', dec2'), ftmap2)  
                  end  
                | MARKdec(dec',r) =>  
                  let val (dec'', ftmap1) = procDec'(ftmap, dec',d)  
                  in (AT.MARKdec(dec'', r), ftmap1)  
                  end  
                | FCTdec(fctbs) =>  
                  let val (fctbs', ftmap1) = fctBinds (ftmap, fctbs,d)  
                  in (AT.FCTdec(fctbs'), ftmap1)  
                  end  
                | STRdec(strbs) =>  
                  let val (strbs', ftmap1) = strBinds(ftmap, strbs)  
                  in (AT.STRdec(strbs'), ftmap1)  
                  end  
                | OPENdec x => (AT.OPENdec x, ftmap) (* May have module dec *)  
                | SIGdec bs => (AT.SIGdec bs, ftmap)  
                | FSIGdec bs => (AT.FSIGdec bs, ftmap)  
                | VALdec vbs => (AT.VALdec (map transVB vbs), ftmap)  
                | VALRECdec rvbs => (AT.VALRECdec (map transRVB rvbs), ftmap)  
                | TYPEdec tycs => (AT.TYPEdec tycs, ftmap)  
                | DATATYPEdec x => (AT.DATATYPEdec x, ftmap)  
                | ABSTYPEdec{abstycs, body, withtycs} =>  
                  let val (body', ftmap1) = procDec'(ftmap,body,d)  
                  in  
                      (AT.ABSTYPEdec{abstycs=abstycs, body=body',  
                                    withtycs=withtycs},  
                       ftmap1)  
                  end  
                | EXCEPTIONdec ebs =>  
                  (AT.EXCEPTIONdec (map (fn (EBgen{exn,etype,ident}) =>  
                                           AT.EBgen{exn=exn,etype=etype,  
                                                    ident= #1 (transExp ftmap d ident)}  
                                         | (EBdef{exn,edef}) =>  
                                           AT.EBdef{exn=exn,edef=edef})  
                                       ebs),  
                   ftmap)  
                | OVLDdec v => (AT.OVLDdec v, ftmap)  
                | FIXdec x => (AT.FIXdec x, ftmap))  
         end (* fun procDec' *)  
     and transExp ftmap d e =  
         (let val transExp' = transExp ftmap d  
              fun transRule(RULE(p,e)) =  
                  let val (e',ftmap1) = transExp' e  
                  in AT.RULE(p,e')  
                  end  
              fun transFnRules(rules, ty) = (map transRule rules, ty)  
          in  
              (case e  
                of VARexp(v,tyvars) => (AT.VARexp(v,tyvars), ftmap)  
                 | (CONexp d) => (AT.CONexp d, ftmap)  
                 | (INTexp d) => (AT.INTexp d, ftmap)  
                 | (WORDexp d) => (AT.WORDexp d, ftmap)  
                 | (REALexp d) => (AT.REALexp d, ftmap)  
                 | (STRINGexp d) => (AT.STRINGexp d, ftmap)  
                 | (CHARexp d) => (AT.CHARexp d, ftmap)  
                 | (RECORDexp recs) =>  
                   (AT.RECORDexp(map (fn(lab,e) => (lab,#1 (transExp' e))) recs),  
                    ftmap)  
                 | (SELECTexp(lab,e)) =>  
                   (AT.SELECTexp (lab, #1 (transExp' e)), ftmap)  
                 | (VECTORexp(es, ty)) =>  
                   (AT.VECTORexp(map (#1 o transExp') es, ty), ftmap)  
                 | (APPexp(e1,e2)) =>  
                   (AT.APPexp(#1 (transExp' e1),  
                             #1 (transExp' e2)), ftmap)  
                 | (HANDLEexp(e,rules)) =>  
                   (AT.HANDLEexp(#1 (transExp' e), transFnRules rules),  
                    ftmap)  
                 | RAISEexp(e,ty) =>  
                   (AT.RAISEexp(#1 (transExp' e), ty), ftmap)  
                 | CASEexp(e,rules, m) =>  
                   (AT.CASEexp(#1 (transExp' e), map transRule rules,m),  
                    ftmap)  
                 | IFexp{test,thenCase,elseCase} =>  
                   (AT.IFexp{test= #1 (transExp' test),  
                            thenCase= #1 (transExp' thenCase),  
                            elseCase= #1 (transExp' elseCase)},  
                    ftmap)  
                 | ANDALSOexp(e1,e2) =>  
                   (AT.ANDALSOexp(#1 (transExp' e1), #1 (transExp' e2)),  
                    ftmap)  
                 | ORELSEexp(e1,e2) =>  
                   (AT.ORELSEexp(#1 (transExp' e1), #1 (transExp' e2)),  
                    ftmap)  
                 | WHILEexp{test,expr} =>  
                   (AT.WHILEexp{test= #1 (transExp' test),  
                               expr= #1 (transExp' expr)},  
                    ftmap)  
                 | FNexp(fnrules) => (AT.FNexp(transFnRules fnrules),  
                                      ftmap)  
                 | LETexp(dec,e) =>  
                   let val (dec',ftmap1) = procDec' (ftmap, dec,d)  
                       val (e',ftmap2) = transExp ftmap1 d e  
                   in (AT.LETexp(dec', e'), ftmap2)  
                   end  
                 | SEQexp(es) => (AT.SEQexp(map (#1 o transExp') es), ftmap)  
                 | CONSTRAINTexp(e,t) =>  
                   (AT.CONSTRAINTexp(#1 (transExp' e), t), ftmap)  
                 | MARKexp(e,r) =>  
                   (AT.MARKexp(#1 (transExp' e), r), ftmap))  
          end) (* transExp *)  
   
     fun procDec(dec, d) = procDec'(FTM.empty, dec, d)  
693  end (* local *)  end (* local *)
694    
695  end (* structure RepTycProps *)  end (* structure RepTycProps *)

Legend:
Removed from v.3292  
changed lines
  Added in v.3293

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