Return to signs.sml CVS log

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

Annotation of researchv10no/cmd/sml/src/parse/signs.sml, revision 1.1

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: signature SIGNS = 
        !             3: sig type spectype
        !             4:     type signtype
        !             5:     type symbol type 'a pathstamped type tyvar type ty type 'a susp
        !             6:     type fixity type tycon
        !             7:     val makeSIGid:     symbol -> signtype
        !             8:     val makeSIG:       spectype -> signtype
        !             9:     val make_includespec: symbol -> spectype
        !            10:     val make_strspec:  symbol * signtype -> spectype
        !            11:     val make_dtyspec:   tycon ref list pathstamped -> spectype
        !            12:     val make_tyspec:   Basics.bool3 * tyvar list * symbol -> spectype
        !            13:     val make_valspec:  symbol * ty susp -> spectype
        !            14:     val make_exnspec:  symbol -> spectype
        !            15:     val make_exnspecOF:        symbol * ty susp-> spectype
        !            16:     val make_fixityspec: fixity * symbol list -> spectype
        !            17:     val make_type_sharespec: symbol list list -> spectype
        !            18:     val make_str_sharespec: symbol list list -> spectype
        !            19: end
        !            20: 
        !            21: structure Signs : SIGNS = struct
        !            22: 
        !            23:   open ErrorMsg Symbol PrintUtil
        !            24:   open Access Basics BasicTypes TypesUtil Absyn
        !            25:   open Env
        !            26:   open EnvAccess
        !            27:   open ModUtil
        !            28:   open SigMatch
        !            29:   open Misc
        !            30: (*   open CoreLang *)
        !            31: 
        !            32: type signContext = {stamps: Stampset.stampsets, nextSlot: unit->int,
        !            33:                    sNext: Structure->Structure, tNext: tycon->tycon,
        !            34:                    sCount: int ref, tCount: int ref,
        !            35:                    tempenv: strenv, depth: int,
        !            36:                    typeSharing: spath list list ref,
        !            37:                    strSharing: spath list list ref}
        !            38: 
        !            39: type stampsets = Stampset.stampsets
        !            40: type 'a stamped = stampsets -> 'a
        !            41: type 'a pathstamped = symbol list * stampsets -> 'a
        !            42: type 'a susp = unit -> 'a
        !            43: type spectype = signContext -> binding list 
        !            44: type signtype = int * stampsets -> Structure
        !            45:                    
        !            46: fun includeSig({nextSlot,sNext,tNext,sCount,tCount,...}: signContext,
        !            47:               {strStamps=strStamps0, tycStamps=tycStamps0}: stampsets,
        !            48:               STRstr{kind=SIGkind{bindings,stamps={strStamps,tycStamps},...},
        !            49:                      env=REL{s=senv,t=tenv},...}) =
        !            50:     let val transStrStamp = Stampset.join(strStamps0,strStamps)
        !            51:        val transTycStamp = Stampset.join(tycStamps0,tycStamps)
        !            52:        val sOffset = !sCount - 2 (* offset for structure indices *)
        !            53:        val tOffset = !tCount     (* offset for tycon indices *)
        !            54: 
        !            55:        (* adjustPath(depth: int, path: int list) *)
        !            56:        fun adjustPath(0,[i]) = [i+tOffset]
        !            57:          | adjustPath(0,i::r) = (i+sOffset) :: r
        !            58:          | adjustPath(0,[]) = impossible "sigBody.includeSig.adjustPath"
        !            59:          | adjustPath(d,0::(r as _::_)) = 0 :: adjustPath(d-1,r)
        !            60:          | adjustPath(d,p) = p
        !            61: 
        !            62:        fun adjustType(depth,ty) =
        !            63:            let fun adjust(CONty(ref(RELtyc(p)),args)) =
        !            64:                      CONty(ref(RELtyc(adjustPath(depth,p))), map adjust args)
        !            65:                  | adjust(CONty(reftyc,args)) =
        !            66:                      CONty(reftyc, map adjust args)
        !            67:                  | adjust(POLYty{sign,tyfun=TYFUN{arity,body}}) =
        !            68:                      POLYty{sign=sign,
        !            69:                             tyfun=TYFUN{arity=arity,body=adjust body}}
        !            70:                  | adjust ty = ty
        !            71:             in adjust ty
        !            72:            end
        !            73: 
        !            74:        fun transTBinding depth binding =
        !            75:            case binding
        !            76:             of VARbind(VALvar{name,typ,access}) =>
        !            77:                  VARbind(VALvar{name=name,access=access,
        !            78:                                 typ=ref(adjustType(depth,!typ))})
        !            79:              | CONbind(DATACON{name,typ,const,rep,sign}) =>
        !            80:                  CONbind(DATACON{name=name, const=const, sign=sign, rep=rep,
        !            81:                                  typ=ref(adjustType(depth,!typ))})
        !            82:              | _ => binding
        !            83: 
        !            84:        fun transLBinding table binding =
        !            85:            case binding
        !            86:             of VARbind(VALvar{name=[n],typ,access}) =>
        !            87:                  IntStrMap.map table (NameSpace.varKey n)
        !            88:              | CONbind(DATACON{name,typ,const,rep,sign}) =>
        !            89:                  IntStrMap.map table (NameSpace.conKey name)
        !            90:              | _ => binding
        !            91: 
        !            92:        fun newTyc(tyc as TYCON{stamp,kind,...}) =
        !            93:            if Stampset.tycFixed(stamp)
        !            94:            then tyc
        !            95:            else (case kind
        !            96:                   of ABStyc => setTycStamp(transTycStamp(stamp),tyc)
        !            97:                    | DATAtyc _ => setTycStamp(transTycStamp(stamp),tyc)
        !            98:                    | _ => tyc)
        !            99:          | newTyc _ = impossible "Parse.includeSig.newTyc"
        !           100: 
        !           101:        fun newEnv(depth,REL{s,t}) =
        !           102:             REL{s=mapSubstrs(newStr depth,s), t=ArrayExt.map(newTyc,t,0)}
        !           103:          | newEnv _ = impossible "Parse.includeSig.newEnv"
        !           104: 
        !           105:        and newStr depth (str as STRstr{stamp,sign,table,env,
        !           106:                                        kind=SIGkind{stamps,share,bindings}}) =
        !           107:            if Stampset.strFixed(stamp)
        !           108:            then str
        !           109:            else let val newenv as REL{s,t} = newEnv(depth+1,env)
        !           110:                     val newtable =
        !           111:                         IntStrMap.transform (transTBinding depth) table
        !           112:                     val new =
        !           113:                         STRstr{stamp=transStrStamp(stamp),
        !           114:                                table=newtable,
        !           115:                                kind=SIGkind{stamps=stamps,share=share,
        !           116:                                             bindings=map
        !           117:                                                      (transLBinding newtable)
        !           118:                                                      bindings},
        !           119:                                      env=newenv, sign=sign}
        !           120:                  in ArrayExt.app(ModUtil.resetParent new, s, 2);
        !           121:                     new
        !           122:                 end
        !           123:          | newStr _ (INDstr i) = impossible("sigbody.newStr INDstr "^
        !           124:                                           makestring i)
        !           125:          | newStr _ (SHRstr _) = impossible "sigbody.newStr SHRstr"
        !           126:          | newStr _ (NULLstr) = impossible "sigbody.newStr NULLstr"
        !           127:          | newStr _ _ = impossible "sigbody.newStr STRkind"
        !           128: 
        !           129:        fun adjustBinding binding =
        !           130:            case binding
        !           131:             of VARbind(VALvar{name=[n],typ,...}) =>
        !           132:                  bindVAR(n,VALvar{name=[n],typ=ref(adjustType(0,!typ)),
        !           133:                                   access=SLOT(nextSlot())})
        !           134:              | CONbind(DATACON{name,typ,const,rep as VARIABLE(SLOT _),sign}) =>
        !           135:                  bindCON(name,DATACON{name=name,
        !           136:                                       const=const,
        !           137:                                       sign=sign,
        !           138:                                       typ=ref(adjustType(0,!typ)),
        !           139:                                       rep=VARIABLE(SLOT(nextSlot()))})
        !           140:              | CONbind(DATACON{name,typ,const,rep,sign}) =>
        !           141:                  bindCON(name,DATACON{name=name,
        !           142:                                       const=const,
        !           143:                                       sign=sign,
        !           144:                                       typ=ref(adjustType(0,!typ)),
        !           145:                                       rep=rep})
        !           146:              | TYCbind(ref(INDtyc i)) =>
        !           147:                  let val tyc = tenv sub i
        !           148:                      val name = tycName tyc
        !           149:                   in bindTYC(name,ref(tNext(newTyc(tyc))))
        !           150:                  end
        !           151:              | STRbind(STRvar{name as [n],binding=INDstr i,...}) =>
        !           152:                  bindSTR(n,STRvar{name=name,
        !           153:                                   binding=sNext(newStr 1 (senv sub i)),
        !           154:                                   access=SLOT(nextSlot())})
        !           155:              | FIXbind(fixvar as FIXvar{name,...}) =>
        !           156:                  bindFIX(name,fixvar)
        !           157:              | _ => impossible "sigBody.adjustBinding"
        !           158: 
        !           159:      in map adjustBinding bindings
        !           160:     end (* includeSig *)
        !           161:   | includeSig _ = impossible "Parse.includeSig - bad arg"
        !           162: 
        !           163: 
        !           164: fun makeSIGid ID (depth,stamps) =
        !           165:     let val SIGvar{binding,...}=lookSIG ID
        !           166:      in if depth>0 then ModUtil.shiftSigStamps(stamps,binding) else binding
        !           167:     end
        !           168:  
        !           169: val maxTypSpecs = 100  (*maximum number of type specs in a signature *)
        !           170: val maxStrSpecs = 100  (*maximum number of structure specs in a signature *)
        !           171: 
        !           172: fun makeSIG(specs) (depth,stamps) = 
        !           173:  let val tComps = array(maxTypSpecs,NULLtyc)
        !           174:      and tCount = ref 0
        !           175:      fun tNext x = (update(tComps,!tCount,x);
        !           176:                    INDtyc(!tCount before inc tCount))
        !           177:      val sComps = array(maxStrSpecs,NULLstr)
        !           178:      and sCount = ref 2 (* slots 0,1 reserved for parent, fct param (if any) *)
        !           179:      fun sNext x = (update(sComps,!sCount,x);
        !           180:                    INDstr(!sCount before inc sCount))
        !           181:      val tempenv = REL{t=tComps,s=sComps}
        !           182:      fun pairs (nil : spath list list) : (spath*spath) list = nil
        !           183:        | pairs ((a::b::r) :: s) = (a,b) :: pairs((b::r) :: s)
        !           184:        | pairs ( _ :: s ) = pairs s
        !           185:      val strSharing : spath list list ref = ref nil
        !           186:      val typeSharing : spath list list ref = ref nil
        !           187: 
        !           188:      val slot = ref 0
        !           189:      fun nextSlot() = (!slot before inc slot)
        !           190: 
        !           191:      val signContext : signContext =
        !           192:                {stamps=stamps,nextSlot=nextSlot, tempenv=tempenv,
        !           193:                 sNext=sNext,tNext=tNext, depth=depth,
        !           194:                 sCount=sCount,tCount=tCount,
        !           195:                 typeSharing=typeSharing,strSharing=strSharing}
        !           196: 
        !           197:      val stamp = Stampset.newStamp(#strStamps stamps)
        !           198:      val _ = openStr()   (* this is out of date, check parse.sml *)
        !           199:      val table = newTable()
        !           200:      val _ = openNew({path=[~depth],strenv=tempenv},table)
        !           201:      val savedlookArTYC = !lookArTYC
        !           202:      val savedlookPathArTYC = !lookPathArTYC
        !           203:      val bindings = protect(
        !           204:         ((fn () => (lookArTYC := lookArTYCinSig depth;
        !           205:                     lookPathArTYC :=
        !           206:                       lookPathArTYCinSig depth)),
        !           207:          (fn () => (lookArTYC := savedlookArTYC;
        !           208:                     lookPathArTYC := savedlookPathArTYC))),
        !           209:          fn() => specs signContext)
        !           210:      val _ = closeStr()
        !           211:      val senv = ArrayExt.copy(sComps,!sCount)
        !           212:      val env = REL{s=senv, t=ArrayExt.copy(tComps,!tCount)}
        !           213:      val sShare = pairs(!strSharing)
        !           214:      val tShare = pairs(!typeSharing)
        !           215:      val shareSpec =
        !           216:            if null sShare andalso null tShare
        !           217:            then {s=[],t=[]}
        !           218:            else Sharing.doSharing(table,env,stamps,{s=sShare,t=tShare})
        !           219:      val result =
        !           220:            STRstr{stamp=stamp,
        !           221:             sign=Stampset.newStamp(Stampset.sigStamps),
        !           222:             table=table,
        !           223:             env=env,
        !           224:             kind=SIGkind{share=shareSpec,
        !           225:                          bindings=bindings,
        !           226:                          stamps=stamps}}
        !           227:   in ArrayExt.app((ModUtil.setParent result),senv,2);
        !           228:      result
        !           229:  end
        !           230: 
        !           231: 
        !           232: fun make_includespec name ($ as {stamps,...}:signContext) =
        !           233:   let val SIGvar{binding,...} = lookSIG name in includeSig($,stamps,binding) end
        !           234: 
        !           235: fun make_strspec(name,sign) ({depth,stamps,nextSlot,sNext,...}:signContext) =
        !           236:   let val sgn = sign(depth+1,stamps)
        !           237:    in [bindSTR(name,STRvar{name=[name],access=SLOT(nextSlot()),
        !           238:                                    binding=sNext(sgn)})]
        !           239:   end
        !           240: 
        !           241: fun make_dtyspec db ({stamps,tempenv,tNext,...}:signContext) =
        !           242:     let val dtycs =
        !           243:         (protect(protectDb(), fn() =>
        !           244:              map (fn (r as ref tyc) => 
        !           245:                    (r := tNext tyc; (TYCbind r, tyc)))
        !           246:                (db1(ty,[],stamps))))
        !           247:        val tycbinds = map (fn (x,_) => x) dtycs
        !           248:        val tycons = map (fn (_,y) => y) dtycs
        !           249:        fun collectdcons(tyc::rest,dcbinds) =
        !           250:             let val TYCON{kind=DATAtyc(dcons),...} = tyc
        !           251:                 fun binddcons(DATACON{name,...}::rest',dcbs) =
        !           252:                      binddcons(rest',
        !           253:                           (let val (b,_) = Env.look(NameSpace.conKey(name))
        !           254:                             in b::dcbs
        !           255:                            end
        !           256:                            handle Unbound => dcbs))
        !           257:                   | binddcons([],dcbs) = dcbs
        !           258:              in collectdcons(rest,binddcons(dcons,dcbinds))
        !           259:             end
        !           260:          | collectdcons([],dcbinds) = dcbinds
        !           261:      in app (defineEqTycon (tyconInContext tempenv)) tycons;
        !           262:        tycbinds @ collectdcons(tycons,[])
        !           263:     end
        !           264: 
        !           265: fun make_tyspec(eq,tyvars,name) ({stamps,tNext,...}:signContext) =
        !           266:      [bindTYC(name, ref(tNext(mkABStyc([name],length tyvars,eq,stamps))))]
        !           267: 
        !           268: fun make_valspec(name,ty) ({nextSlot,...}:signContext) =
        !           269:    let val typ = protect(protectScope, fn () =>
        !           270:                      protect(protectTyvars NONE, fn () =>
        !           271:                        let val body = ty()
        !           272:                            val tvs = currentTyvars()
        !           273:                         in case tvs
        !           274:                              of [] => body
        !           275:                               | _ =>
        !           276:                                 let val sign = TypesUtil.bindTyvars1 tvs
        !           277:                                  in POLYty
        !           278:                                      {sign = sign,
        !           279:                                       tyfun = TYFUN{arity = length tvs, 
        !           280:                                                     body = body}}
        !           281:                                 end
        !           282:                        end))
        !           283:    in [bindVAR(name,VALvar{name=[name],typ=ref typ,access=SLOT(nextSlot())})]
        !           284:   end
        !           285: 
        !           286: fun make_exnspec name ({nextSlot,...}:signContext) =
        !           287:   [bindCON(name,DATACON{name=name,const=true,typ=ref exnTy,sign=[],
        !           288:                rep=VARIABLE(SLOT(nextSlot()))})]
        !           289: 
        !           290: fun make_exnspecOF(name,ty) ({nextSlot,...}:signContext) =
        !           291:   let val typ = protect(protectScope, fn()=>
        !           292:                  protect(protectTyvars NONE, fn()=>
        !           293:                        let val body = ty()
        !           294:                            val tvs = currentTyvars()
        !           295:                         in case length tvs
        !           296:                             of 0 => body --> exnTy
        !           297:                              | n => (TypesUtil.bindTyvars tvs;
        !           298:                                      POLYty{sign = mkPolySign n,
        !           299:                                         tyfun = TYFUN{arity = n,
        !           300:                                                     body = body --> exnTy}})
        !           301:                           end))
        !           302:    in [bindCON(name, DATACON{name=name, const=false, typ= ref typ,sign=[],
        !           303:                                      rep=VARIABLE(SLOT(nextSlot()))})]
        !           304:   end
        !           305: 
        !           306: fun make_fixityspec(fixity,ops) _ = 
        !           307:   (app(fn i => bindFIX(i,FIXvar{name=i,binding=fixity})) ops;  nil)
        !           308: 
        !           309: fun make_type_sharespec patheqn ({typeSharing,...}:signContext) =
        !           310:                (typeSharing := patheqn :: !typeSharing; nil)
        !           311: 
        !           312: fun make_str_sharespec patheqn ({strSharing,...}:signContext) =
        !           313:                (strSharing := patheqn :: !strSharing; nil)
        !           314: end

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