Return to modutil.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / basics

Annotation of researchv10no/cmd/sml/src/basics/modutil.sml, revision 1.1

1.1     ! root        1: (* modutil.sml *)
        !             2: 
        !             3: structure ModUtil : MODUTIL =
        !             4: struct
        !             5: 
        !             6: open ErrorMsg Basics TypesUtil Stampset
        !             7: 
        !             8: fun mapSubstrs(f,senv) =
        !             9:   (* Creates a new copy of a structure environment array by applying f to
        !            10:      substructures.  Leaves parent and param slots of new env undefined *)  
        !            11:     let val new = array(Array.length senv, NULLstr)
        !            12:        fun loop i = (update(new,i,f(senv sub i)); loop(i+1))
        !            13:      in loop 2 handle Subscript => new
        !            14:     end
        !            15: 
        !            16: (* setParent only sets parents that are initially NULLstr *)
        !            17: fun setParent (parent: Structure) =
        !            18:     fn (STRstr{env=REL{s,...},...}) =>
        !            19:        ((case s sub 0
        !            20:           of NULLstr => update(s,0,parent)
        !            21:            | _ => ())
        !            22:         handle Subscript => ())
        !            23:      | (STRstr{env=DIR,...}) => ()
        !            24:      | NULLstr => ()
        !            25:      | _ => impossible "ModUtil.setParent"
        !            26: 
        !            27: (* resetParent redefines parents unconditionally *)
        !            28: fun resetParent (parent: Structure) =
        !            29:     fn (STRstr{env=REL{s,...},...}) =>
        !            30:          (update(s,0,parent) handle Subscript => impossible "ModUtil.resetParent 1")
        !            31:      | (STRstr{env=DIR,...}) => ()
        !            32:      | NULLstr => ()
        !            33:      | _ => impossible "ModUtil.resetParent 2"
        !            34: 
        !            35: fun linkParents(str as STRstr{env=REL{s,...},...}) =
        !            36:     ArrayExt.app((fn str' => (setParent str str'; linkParents str')), s, 1)
        !            37:   | linkParents(STRstr{env=DIR,...}) = ()
        !            38:   | linkParents(NULLstr) = ()
        !            39:   | linkParents _ = ErrorMsg.impossible "ModUtil.linkParents"
        !            40: 
        !            41: fun shiftStamps(transStrStamp,transTycStamp,newStamps,fixstamp,fixsign,fixstr) =
        !            42:     let fun newTyc(tyc as TYCON{stamp,arity,eq,path,kind}) =
        !            43:            if tycFixed(stamp)
        !            44:            then tyc
        !            45:            else (case kind
        !            46:                   of ABStyc => setTycStamp(transTycStamp(stamp),tyc)
        !            47:                    | DATAtyc _ => setTycStamp(transTycStamp(stamp),tyc)
        !            48:                    | DEFtyc(TYFUN{arity,body}) =>
        !            49:                       TYCON{stamp=transTycStamp(stamp),
        !            50:                             arity=arity,
        !            51:                             eq=eq,
        !            52:                             path=path,
        !            53:                             kind=DEFtyc(TYFUN{arity=arity,
        !            54:                                               body=newType(body)})}
        !            55:                    | _ => tyc)
        !            56:          | newTyc _ = impossible "ModUtil.shiftStamps.newTyc - bad arg"
        !            57:        and newType(ty) =
        !            58:            case ty
        !            59:              of VARty(ref(INSTANTIATED ty')) => newType ty'
        !            60:               | FLEXRECORDty(ref(CLOSED ty')) => newType ty'
        !            61:               | POLYty{tyfun=TYFUN{body,arity},sign} =>
        !            62:                   POLYty{tyfun=TYFUN{body=newType body,arity=arity},sign=sign}
        !            63:               | VARty _ => ty
        !            64:               | CONty(tycref as ref tyc,args) =>
        !            65:                   CONty(ref(newTyc(tyc)), map newType args)
        !            66:               | ERRORty => ty
        !            67:               | _ => impossible "shiftStamps.newType"
        !            68:         fun newEnv(REL{s,t}) =
        !            69:            let val s' = array(Array.length s, NULLstr)
        !            70:                fun loop i = (update(s',i,newStr(s sub i)); loop(i+1))
        !            71:             in loop 1 handle Subscript => 
        !            72:                  REL{s=s',t=ArrayExt.map(newTyc,t,0)}
        !            73:            end
        !            74:          | newEnv _ = impossible "ModUtil.shiftStamps.newEnv - bad arg"
        !            75:        and newStr(str as STRstr{stamp,sign,table,env,kind}) =
        !            76:            if Stampset.strFixed(stamp)
        !            77:            then str
        !            78:            else if stamp=fixstamp andalso sign=fixsign
        !            79:            then fixstr
        !            80:            else let val newenv as REL{s,...} = newEnv env
        !            81:                     val new = STRstr{stamp=transStrStamp(stamp),
        !            82:                                      kind=case kind
        !            83:                                             of SIGkind{stamps,share,bindings} =>
        !            84:                                                 SIGkind{stamps=newStamps,
        !            85:                                                         share=share,
        !            86:                                                         bindings=bindings}
        !            87:                                              | _ => kind,
        !            88:                                      env=newenv,
        !            89:                                      sign=sign,table=table}
        !            90:                     val setpar = setParent new
        !            91:                     fun loop i = (setpar(s sub i); loop(i+1))
        !            92:                  in loop 1 handle Subscript => new
        !            93:                 end
        !            94:          | newStr(NULLstr) = NULLstr
        !            95:           | newStr(INDstr i) = impossible("ModUtil.shiftStamps.newStr INDstr "^
        !            96:                                           makestring i)
        !            97:          | newStr(SHRstr _) = impossible "ModUtil.shiftStamps.newStr SHRstr"
        !            98:      in newStr
        !            99:     end
        !           100: 
        !           101: fun shiftSigStamps(base : stampsets, sgn as STRstr{kind=SIGkind{stamps,...},...}) =
        !           102:     let val {strStamps=sbase,tycStamps=tbase} = base
        !           103:        and {strStamps=soffset,tycStamps=toffset} = stamps
        !           104:         val transStrStamp = join(sbase,soffset)
        !           105:        and transTycStamp = join(tbase,toffset)
        !           106:      in shiftStamps(transStrStamp,transTycStamp,base,~1,~1,NULLstr) sgn
        !           107:     end
        !           108:   | shiftSigStamps _ = impossible "ModUtil.shiftSigStamps -- bad arg"
        !           109: 
        !           110: fun shiftFctStamps(FUNCTOR{paramName,paramVis,param,body,
        !           111:                           stamps as {strStamps=bodyStrStamps,
        !           112:                                      tycStamps=bodyTycStamps}}) =
        !           113:     let val newParamStamps = newStampsets()
        !           114:        val newBodyStamps = newStampsets()
        !           115:        val STRstr{stamp=pstamp,sign=psign,
        !           116:                   kind=SIGkind{stamps=pstamps as {strStamps=paramStrStamps,
        !           117:                                                   tycStamps=paramTycStamps},
        !           118:                                ...},
        !           119:                   ...} =
        !           120:              param
        !           121:        val bodyStrTrans = join(#strStamps newBodyStamps, bodyStrStamps)
        !           122:        val bodyTycTrans = join(#tycStamps newBodyStamps, bodyTycStamps)
        !           123:        val paramStrTrans = join(#strStamps newParamStamps, paramStrStamps)
        !           124:        val paramTycTrans = join(#tycStamps newParamStamps, paramTycStamps)
        !           125:        fun transStrStamps x =
        !           126:            if member(x,bodyStrStamps)
        !           127:            then bodyStrTrans x
        !           128:            else if member(x,paramStrStamps)
        !           129:            then paramStrTrans x
        !           130:            else x
        !           131:        fun transTycStamps x =
        !           132:            if member(x,bodyTycStamps)
        !           133:            then bodyTycTrans x
        !           134:            else if member(x,paramTycStamps)
        !           135:            then paramTycTrans x
        !           136:            else x
        !           137:        val newparam = shiftStamps(paramStrTrans,paramTycTrans,newParamStamps,
        !           138:                                   ~1,~1,NULLstr)
        !           139:                                  param
        !           140:        val newbody = shiftStamps (transStrStamps,transTycStamps,newBodyStamps,
        !           141:                                   pstamp,psign,newparam)
        !           142:                                  body
        !           143:      in FUNCTOR{paramName=paramName,
        !           144:                paramVis=paramVis,
        !           145:                param=newparam,
        !           146:                body=newbody,
        !           147:                stamps=newBodyStamps}
        !           148:     end
        !           149: 
        !           150: end (* structure ModUtil *)

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.