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/Semant/modules/moduleutil.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Semant/modules/moduleutil.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 79  Line 79 
79          (case EE.look(entEnv,entVar)          (case EE.look(entEnv,entVar)
80            of STRent entity =>            of STRent entity =>
81                 (STR{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),                 (STR{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),
82                      info = II.selInfo(dinfo, slot)}, entVar)                      info = II.selInfo(dinfo, slot)},
83                    entVar)
84             | _ => bug "getStr: bad entity")             | _ => bug "getStr: bad entity")
85       | _ => bug "getStr: wrong spec"       | _ => bug "getStr: wrong spec"
86    
# Line 90  Line 91 
91          (case EE.look(entEnv,entVar)          (case EE.look(entEnv,entVar)
92            of FCTent entity =>            of FCTent entity =>
93                 (FCT{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),                 (FCT{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),
94                      info = II.selInfo(dinfo, slot)}, entVar)                      info = II.selInfo(dinfo, slot)},
95                    entVar)
96             | _ => bug "getFct: bad entity")             | _ => bug "getFct: bad entity")
97       | _ => bug "getFct: wrong spec"       | _ => bug "getFct: wrong spec"
98    
# Line 105  Line 107 
107    | getStrName ERRORstr = errorStrName    | getStrName ERRORstr = errorStrName
108    | getStrName _ = bug "getStrName"    | getStrName _ = bug "getStrName"
109    
110  fun getStrs(STR{sign=SIG{elements,...},rlzn={entities,...}, access, info}) =  fun getStrs (STR { sign = SIG sg, rlzn = {entities,...}, access,info,...}) =
111        let val elements = #elements sg
112        in
113        List.mapPartial        List.mapPartial
114          (fn (sym,STRspec{sign,slot,def,entVar}) =>          (fn (sym,STRspec{sign,slot,def,entVar}) =>
115               SOME(STR{sign = sign,               SOME(STR{sign = sign,
116                        rlzn = EE.lookStrEnt(entities,entVar),                        rlzn = EE.lookStrEnt(entities,entVar),
117                        access = A.selAcc(access, slot),                        access = A.selAcc(access, slot),
118                        info = II.selInfo(info, slot)})                        info = II.selInfo(info, slot)})
119            | _ => NONE) elements                 | _ => NONE)
120                elements
121        end
122    | getStrs ERRORstr = nil    | getStrs ERRORstr = nil
123    | getStrs _ = bug "getStrs"    | getStrs _ = bug "getStrs"
124    
125  fun getTycs(STR{sign=SIG{elements,...},rlzn={entities,...},...}) =  fun getTycs (STR { sign = SIG sg, rlzn = {entities,...}, ... }) =
126        let val tycvars = List.mapPartial      let val elements = #elements sg
127            val tycvars = List.mapPartial
128                            (fn (sym,TYCspec{entVar,...}) => SOME entVar                            (fn (sym,TYCspec{entVar,...}) => SOME entVar
129                              | _ => NONE) elements                              | _ => NONE)
130         in List.map (fn tycVar => EE.lookTycEnt(entities,tycVar)) tycvars                            elements
131        in
132            List.map (fn tycVar => EE.lookTycEnt(entities,tycVar)) tycvars
133        end        end
134    | getTycs ERRORstr = nil    | getTycs ERRORstr = nil
135    | getTycs _ = bug "getTycs"    | getTycs _ = bug "getTycs (2)"
136    
137  fun getSigSymbols(SIG{symbols,...}) = symbols  fun getSigSymbols(SIG{symbols,...}) = symbols
138    | getSigSymbols _ = nil    | getSigSymbols _ = nil
# Line 184  Line 193 
193              (let val newInfo =              (let val newInfo =
194                    case sInfo                    case sInfo
195                     of SIGINFO ep => SIGINFO (entVar::ep)                     of SIGINFO ep => SIGINFO (entVar::ep)
196                      | STRINFO (rlzn as {entities,...}, dacc, dinfo) =>                      | STRINFO ({entities,...}, dacc, dinfo) =>
197                            STRINFO(EE.lookStrEnt(entities,entVar),                            STRINFO(EE.lookStrEnt(entities,entVar),
198                                    A.selAcc(dacc,slot), II.selInfo(dinfo,slot))                                    A.selAcc(dacc,slot), II.selInfo(dinfo,slot))
199                in (subsig, newInfo)                in (subsig, newInfo)
# Line 210  Line 219 
219                 of SIGINFO ep =>                 of SIGINFO ep =>
220                      T.PATHtyc{arity=TU.tyconArity spec, entPath=rev(ev::ep),                      T.PATHtyc{arity=TU.tyconArity spec, entPath=rev(ev::ep),
221                                path=CVP.invertSPath sp}                                path=CVP.invertSPath sp}
222                  | STRINFO (rlzn as {entities,...}, _, _) =>                  | STRINFO ({entities,...}, _, _) =>
223                      EE.lookTycEnt(entities, ev))                      EE.lookTycEnt(entities, ev))
224    
225           | _ => bug "mkTyc: wrong spec case")           | _ => bug "mkTyc: wrong spec case")
# Line 219  Line 228 
228    
229  fun mkVal(sym, sp, sign as SIG{elements,...},  fun mkVal(sym, sp, sign as SIG{elements,...},
230                     sInfo as STRINFO({entities,...}, dacc, dinfo)) : V.value =                     sInfo as STRINFO({entities,...}, dacc, dinfo)) : V.value =
231        (case getSpec(elements, sym)      (case getSpec(elements, sym) of
232          of VALspec{spec,slot} =>           VALspec{spec,slot} =>
233               V.VAL(V.VALvar{access = A.selAcc(dacc,slot),               V.VAL(V.VALvar{access = A.selAcc(dacc,slot),
234                              info = II.selInfo(dinfo,slot), path = sp,                              info = II.selInfo(dinfo,slot), path = sp,
235                              typ = ref(transType entities spec)})                              typ = ref(transType entities spec)})
236           | CONspec{spec=T.DATACON{name, const, typ, rep, sign, lazyp},
237           | CONspec{spec=T.DATACON{name, const, typ, rep, sign, lazyp}, slot} =>                   slot} =>
238               let val newrep =               let val newrep =
239                     case (rep, slot)                     case (rep, slot)
240                      of (A.EXN _, SOME i) => A.EXN (A.selAcc(dacc,i))                      of (A.EXN _, SOME i) => A.EXN (A.selAcc(dacc,i))
241                       | _ => rep                       | _ => rep
242    
243                in V.CON(T.DATACON{rep=newrep, name=name,           in
244                 V.CON(T.DATACON{rep=newrep, name=name,
245                                   typ=transType entities typ,                                   typ=transType entities typ,
246                                   const=const, sign=sign, lazyp=lazyp})                                   const=const, sign=sign, lazyp=lazyp})
247               end               end
   
248           | _ => bug "mkVal: wrong spec")           | _ => bug "mkVal: wrong spec")
   
249    | mkVal _ = V.VAL(V.ERRORvar)    | mkVal _ = V.VAL(V.ERRORvar)
250    
   
251  fun mkStrBase(sym, sign, sInfo) =  fun mkStrBase(sym, sign, sInfo) =
252    let val (newsig, newInfo) = getStrElem(sym, sign, sInfo)    let val (newsig, newInfo) = getStrElem(sym, sign, sInfo)
253     in case newsig     in case newsig
# Line 297  Line 304 
304    
305  fun checkPathSig(sign: M.Signature, spath: SP.path) : S.symbol option =  fun checkPathSig(sign: M.Signature, spath: SP.path) : S.symbol option =
306      let val str = STRSIG{sign=sign,entPath=[]:EP.entPath}      let val str = STRSIG{sign=sign,entPath=[]:EP.entPath}
307          fun checkLast(sym,_,SIG{elements,...},_) = (getSpec(elements,sym);())          fun checkLast(sym,_,SIG {elements,...},_) =
308                (getSpec(elements,sym); ())
309            | checkLast(sym,_,ERRORsig,_) = ()            | checkLast(sym,_,ERRORsig,_) = ()
310       in getPath checkLast (str,spath,SP.empty);       in getPath checkLast (str,spath,SP.empty);
311          NONE          NONE
# Line 316  Line 324 
324             SIG{stamp=s2,closed=true, ...}) = ST.eq(s1,s2)             SIG{stamp=s2,closed=true, ...}) = ST.eq(s1,s2)
325    | eqSign _ = false    | eqSign _ = false
326    
327  fun eqOrigin(STR{rlzn={stamp=s1,...},...},  fun eqOrigin(STR s1, STR s2) = ST.eq (#stamp (#rlzn s1), #stamp (#rlzn s2))
              STR{rlzn={stamp=s2,...},...}) = ST.eq(s1,s2)  
328    | eqOrigin _ = false    | eqOrigin _ = false
329    
   
330  (*  (*
331   * The following functions are used in CMStaticEnv and module elaboration   * The following functions are used in CMStaticEnv and module elaboration
332   * for building EntPathContexts.  They extract module ids from modules.   * for building EntPathContexts.  They extract module ids from modules.
333   *)   *)
334  fun tycId(T.GENtyc{stamp,...}) = ModuleId.TYCid stamp  val tycId = MI.tycId'
   | tycId(T.DEFtyc{stamp,...}) = ModuleId.TYCid stamp  
   | tycId _ = bug "tycId"  
335    
336  fun strId(STR{rlzn={stamp=rlznst,...},sign=SIG{stamp=sigst,...},...}) =  fun strId (STR sa) = MI.strId sa
       MI.STRid{rlzn=rlznst,sign=sigst}  
337    | strId _ = bug "strId"    | strId _ = bug "strId"
338    
339  fun strId2(SIG{stamp=sigst,...}, {stamp=rlznst,...} : strEntity) =  fun strId2(SIG sa, rlzn : strEntity) = MI.strId2 (sa, rlzn)
       MI.STRid{rlzn=rlznst,sign=sigst}  
340    | strId2 _ = bug "strId2"    | strId2 _ = bug "strId2"
341    
342  fun fsigId(FSIG{paramsig=SIG{stamp=sp,...},bodysig=SIG{stamp=sb,...},...}) =  fun fctId (FCT fa) = MI.fctId fa
       MI.FSIGid{paramsig=sp,bodysig=sb}  
   | fsigId _ = bug "fsigId"  
   
 fun fctId(FCT{rlzn={stamp,...},sign, ...}) =  
       MI.FCTid{rlzn=stamp,sign=fsigId sign}  
343    | fctId _ = bug "fctId"    | fctId _ = bug "fctId"
344    
345  fun fctId2(sign, {stamp,...} : fctEntity) =  fun fctId2(sign, rlzn : fctEntity) = MI.fctId2 (sign, rlzn)
       MI.FCTid{rlzn=stamp,sign=fsigId sign}  
346    
347  (*  (*
348   * The reason that relativizeType does not need to get inside   * The reason that relativizeType does not need to get inside
# Line 355  Line 351 
351   * otherwise, this DEFtyc must be a rigid tycon.   * otherwise, this DEFtyc must be a rigid tycon.
352   *)   *)
353  fun relativizeTyc epContext : T.tycon -> T.tycon * bool =  fun relativizeTyc epContext : T.tycon -> T.tycon * bool =
354    let fun mapTyc(tyc as (T.GENtyc{stamp,...} | T.DEFtyc{stamp,...})) =      let fun stamped tyc = let
355              let val tyc_id = ModuleId.TYCid stamp              val tyc_id = MI.tycId' tyc
356               in debugmsg ("mapTyc: "^ModuleId.idToString tyc_id);          in
357                  case EPC.lookPath(epContext,tyc_id)              (* debugmsg ("mapTyc: "^ModuleId.idToString tyc_id); *)
358                case EPC.lookTycPath(epContext,tyc_id)
359                    of NONE => (debugmsg "tyc not mapped 1"; (tyc,false))                    of NONE => (debugmsg "tyc not mapped 1"; (tyc,false))
360                     | SOME entPath =>                     | SOME entPath =>
361                       let val tyc' = T.PATHtyc{arity=TU.tyconArity tyc,                       let val tyc' = T.PATHtyc{arity=TU.tyconArity tyc,
362                                                entPath=entPath,                                                entPath=entPath,
363                                                path=TU.tycPath tyc}                                                path=TU.tycPath tyc}
364                        in debugmsg("tyc mapped: "^                  in
365                        debugmsg("tyc mapped: "^
366                                   Symbol.name(TypesUtil.tycName tyc'));                                   Symbol.name(TypesUtil.tycName tyc'));
367                           (tyc',true)                           (tyc',true)
368                       end                       end
369              end              end
370    
371            fun mapTyc (tyc as (T.GENtyc _ | T.DEFtyc _)) = stamped tyc
372            | mapTyc(tyc as T.PATHtyc _) =            | mapTyc(tyc as T.PATHtyc _) =
373               (* assume this is a local tycon within the current signature *)               (* assume this is a local tycon within the current signature *)
374               (debugmsg "tyc not mapped 2";               (debugmsg "tyc not mapped 2";
# Line 405  Line 405 
405   *  - used only inside the function openStructure   *  - used only inside the function openStructure
406   *  - raises ModuleUtil.Unbound if sym not found in sig   *  - raises ModuleUtil.Unbound if sym not found in sig
407   *)   *)
408  fun getBinding (sym, str as STR{sign as SIG{elements,...},  fun getBinding (sym, str as STR st) =
409                                  rlzn as {entities,...},      (case st of
410                                  access=dacc, info=dinfo}) =           {sign as SIG _, rlzn, access=dacc, info=dinfo} =>
411       let val sinfo = STRINFO(rlzn, dacc, dinfo)       let val sinfo = STRINFO(rlzn, dacc, dinfo)
412        in case S.nameSpace sym               val entities = #entities rlzn
413             in
414                 case S.nameSpace sym
415            of S.VALspace =>            of S.VALspace =>
416                 (case mkVal(sym, SP.SPATH[sym], sign, sinfo)                 (case mkVal(sym, SP.SPATH[sym], sign, sinfo)
417                   of V.VAL v => B.VALbind v                   of V.VAL v => B.VALbind v
418                    | V.CON d => B.CONbind d)                    | V.CON d => B.CONbind d)
419                   | S.TYCspace =>
420             | S.TYCspace => B.TYCbind(mkTyc(sym, SP.SPATH[sym], sign, sinfo))                   B.TYCbind (mkTyc(sym, SP.SPATH[sym], sign, sinfo))
421             | S.STRspace => B.STRbind(mkStrBase(sym, sign, sinfo))             | S.STRspace => B.STRbind(mkStrBase(sym, sign, sinfo))
422             | S.FCTspace => B.FCTbind(getFctElem(sym, sign, sinfo))             | S.FCTspace => B.FCTbind(getFctElem(sym, sign, sinfo))
423             | sp => (debugmsg ("getBinding: "^S.symbolToString sym);             | sp => (debugmsg ("getBinding: "^S.symbolToString sym);
424                      raise (Unbound sym))                      raise (Unbound sym))
425       end       end
426           | { sign = ERRORsig, ... } => errBinding sym)
427    | getBinding (sym, STRSIG{sign as SIG{elements, ...},entPath=ep}) =    | getBinding (sym, STRSIG{sign as SIG _,entPath=ep}) =
428       let val sinfo = SIGINFO(rev ep)       let val sinfo = SIGINFO(rev ep)
429        in case S.nameSpace sym       in
430            of S.TYCspace => B.TYCbind(mkTyc(sym, SP.SPATH[sym], sign, sinfo))           case S.nameSpace sym
431              of S.TYCspace =>
432                 B.TYCbind (mkTyc(sym, SP.SPATH[sym], sign, sinfo))
433             | S.STRspace => B.STRbind(mkStrBase(sym, sign, sinfo))             | S.STRspace => B.STRbind(mkStrBase(sym, sign, sinfo))
434             | _ => (debugmsg ("getBinding: "^S.symbolToString sym);             | _ => (debugmsg ("getBinding: "^S.symbolToString sym);
435                     raise (Unbound sym))                     raise (Unbound sym))
436       end       end
   
   | getBinding (sym, STR{sign=ERRORsig,...}) = errBinding sym  
437    | getBinding (sym, ERRORstr) = errBinding sym    | getBinding (sym, ERRORstr) = errBinding sym
438    | getBinding _ = bug "getBinding - bad arg"    | getBinding _ = bug "getBinding - bad arg"
439    
# Line 448  Line 450 
450    | extractInfo(B.FCTbind(M.FCT{info, ...})) = info    | extractInfo(B.FCTbind(M.FCT{info, ...})) = info
451    | extractInfo(B.VALbind(V.VALvar{info, ...})) = info    | extractInfo(B.VALbind(V.VALvar{info, ...})) = info
452    | extractInfo(B.CONbind _) = II.nullInfo    | extractInfo(B.CONbind _) = II.nullInfo
   | extractInfo(B.STRbind _) = II.nullInfo  
   | extractInfo(B.FCTbind _) = II.nullInfo  
453    | extractInfo _ = bug "unexpected binding in extractInfo"    | extractInfo _ = bug "unexpected binding in extractInfo"
454    
455  (* extract all signature names from a structure --  (* extract all signature names from a structure --
456   *  doesn't look into functor components *)   *  doesn't look into functor components *)
457  fun getSignatureNames(STR{sign,...} | STRSIG{sign,...}) =  fun getSignatureNames s = let
458      let fun sigNames(SIG{name,elements,...},names) =      fun fromSig sign = let
459            fun sigNames(SIG {name,elements,...}, names) =
460              foldl (fn ((_,STRspec{sign,...}),ns) =>              foldl (fn ((_,STRspec{sign,...}),ns) =>
461                         sigNames(sign, ns)                         sigNames(sign, ns)
462                      | (_,ns) => ns)                      | (_,ns) => ns)
# Line 468  Line 469 
469            | removeDups (nil,z) = z            | removeDups (nil,z) = z
470       in removeDups(ListMergeSort.sort S.symbolGt(sigNames(sign,nil)), nil)       in removeDups(ListMergeSort.sort S.symbolGt(sigNames(sign,nil)), nil)
471      end      end
472    | getSignatureNames(ERRORstr) = nil  in
473        case s of
474            STR { sign, ... } => fromSig sign
475          | STRSIG { sign, ... } => fromSig sign
476          | ERRORstr => nil
477    end
478  end (* local *)  end (* local *)
479  end (* structure ModuleUtil *)  end (* structure ModuleUtil *)
480    

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