![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to misc.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / parse|
Return to misc.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / parse |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: (* misc.sml *) ! 3: ! 4: structure Misc : MISC = ! 5: struct ! 6: ! 7: open ErrorMsg Symbol PrintUtil Access Basics BasicTypes ! 8: TypesUtil Absyn EnvAccess EnvAccess.Env ! 9: ! 10: val ASTERISKsym = Symbol.symbol "*" ! 11: val EQUALsym = Symbol.symbol "=" ! 12: ! 13: fun for l f = app f l ! 14: ! 15: local fun uniq ((a0 as (a,_,_))::(r as (b,_,_)::_)) = ! 16: if Symbol.eq(a,b) then uniq r else a0::uniq r ! 17: | uniq l = l ! 18: fun gtr((a,_,_),(b,_,_)) = ! 19: let val a' = Symbol.name a and b' = Symbol.name b ! 20: val zero = ord "0" and nine = ord "9" ! 21: val a0 = ordof(a',0) and b0 = ordof(b',0) ! 22: in if a0 >= zero andalso a0 <= nine ! 23: then if b0 >= zero andalso b0 <= nine ! 24: then size a' > size b' orelse ! 25: size a' = size b' andalso a' > b' ! 26: else false ! 27: else if b0 >= zero andalso b0 <= nine ! 28: then true ! 29: else a' > b' ! 30: end ! 31: in val sort3 = uniq o Sort.sort gtr ! 32: end ! 33: ! 34: fun protect((enter,exit),doit) = ! 35: let val t = enter() ! 36: in (doit() before exit t) ! 37: handle exn => (exit t; raise exn) ! 38: end ! 39: ! 40: val protectScope = (openScope,resetEnv) ! 41: ! 42: (* following could go in Absyn *) ! 43: val bogusID = Symbol.symbol "bogus" ! 44: val bogusExnID = Symbol.symbol "Bogus" ! 45: val bogusExp = VARexp(ref(mkVALvar(bogusID, ref ERRORty))) ! 46: ! 47: val anonName = Symbol.symbol "Anon" ! 48: val anonParamName = Symbol.symbol "AnonParam" ! 49: ! 50: val nullSigStamp = Stampset.newStamp(Stampset.sigStamps) ! 51: val nullSigStampsets = Stampset.newStampsets() ! 52: val nullStrenv = REL{s=arrayoflist [NULLstr,NULLstr], t=arrayoflist []} ! 53: val nullSig = ! 54: STRstr{stamp = Stampset.newStamp(#strStamps nullSigStampsets), ! 55: sign = nullSigStamp, ! 56: table = newTable(), ! 57: env = nullStrenv, ! 58: kind = SIGkind{share = {s=[],t=[]}, ! 59: bindings = [], ! 60: stamps = nullSigStampsets}} ! 61: val nullStr = ! 62: STRstr{stamp = Stampset.newStamp(Stampset.fixedStrStamps), ! 63: sign = nullSigStamp, ! 64: table = newTable(), ! 65: env = nullStrenv, ! 66: kind = STRkind{path=[Symbol.symbol "NullStructure"]}} ! 67: val nullParamVar = STRvar{name=[anonParamName], ! 68: access=LVAR(namedLvar(anonParamName)), ! 69: binding=nullSig} ! 70: ! 71: fun discard _ = () ! 72: ! 73: fun single x = [x] ! 74: ! 75: fun varcon (VARbind v) = VARexp(ref v) ! 76: | varcon (CONbind d) = CONexp d ! 77: | varcon _ = impossible "parse.39" ! 78: ! 79: fun lookID(id : symbol): exp = ! 80: varcon (lookVARCON id handle Unbound => unboundVAR id) ! 81: handle Unboundrec => VARexp(getPatchVar id) ! 82: ! 83: val lookIDinStr = varcon o lookVARCONinStr ! 84: ! 85: (* the following two functions belong in TypesUtil *) ! 86: fun checkNonCircular(l : tycon list) = ! 87: let fun less(TYCON{path=a::_,...},TYCON{kind=DEFtyc(TYFUN{body,...}),...}) = ! 88: let fun find(CONty(ref(TYCON{path=b::_,...}), args)) = ! 89: Symbol.eq(a,b) orelse exists find args ! 90: | find(CONty(_, args)) = exists find args ! 91: | find _ = false ! 92: in find body ! 93: end ! 94: | less _ = impossible "Misc.checkNonCircular" ! 95: in (Topsort.topsort2 less l; ()) ! 96: handle Topsort.Cycle => complain "circular withtype declaration" ! 97: end ! 98: ! 99: fun makeAbstract(datatycs,withtycs) = ! 100: let val (stamps,abstycs,dconss) = ! 101: let fun loop((tr as ref(TYCON{stamp,arity,eq,path, ! 102: kind=DATAtyc dcons})) ! 103: ::rest,stamps,abstycs,dconss) = ! 104: let val abstyc = TYCON{stamp=stamp,arity=arity,path=path, ! 105: eq=ref NO,kind=ABStyc} ! 106: in tr := abstyc; ! 107: loop(rest,stamp::stamps,abstyc::abstycs,dcons::dconss) ! 108: end ! 109: | loop([],stamps,abstycs,dconss) = (stamps,abstycs,dconss) ! 110: | loop _ = impossible "Misc.makeAbstract.loop" ! 111: in loop(datatycs,[],[],[]) ! 112: end ! 113: fun subst(tycref as ref(TYCON{stamp,...})) = ! 114: let fun find(stamp'::stamps,tyc::tycs) = ! 115: if stamp = stamp' then tycref := tyc else find(stamps,tycs) ! 116: | find([],_) = () ! 117: | find _ = impossible "Misc.makeAbstract.subst.find" ! 118: in find(stamps,abstycs) ! 119: end ! 120: | subst _ = () ! 121: fun substType(CONty(reftyc,args)) = ! 122: (subst reftyc; app substType args) ! 123: | substType(POLYty{tyfun=TYFUN{body,...},...}) = substType body ! 124: | substType _ = () ! 125: in for dconss (app (fn DATACON{typ,...} => substType(!typ))); ! 126: for withtycs ! 127: (fn ref(TYCON{kind=DEFtyc(TYFUN{body,...}),...}) => substType body ! 128: | _ => impossible "Misc.makeAbstract.fn"); ! 129: abstycs ! 130: end ! 131: ! 132: fun dumpStructure(STRvar{access=PATH p,binding,...}) = ! 133: let val STRstr{table,env,...} = binding ! 134: val vbs = ref ([]: vb list) ! 135: and strbs = ref([]: strb list) ! 136: and tbs = ref([]: tb list) ! 137: and ebs = ref([]: eb list) ! 138: fun rebind(index,strg,VARbind(var)) = ! 139: (case varApplied(var,{path=p,strenv=env},[symbol strg]) ! 140: of oldvar as VALvar{name=[n],typ,...} => ! 141: let val newvar = mkVALvar(n,typ) ! 142: val vb = VB{pat = VARpat(newvar), ! 143: exp = VARexp(ref oldvar), ! 144: tyvars = []} ! 145: in vbs := vb :: !vbs; ! 146: Env.add(index,strg,VARbind newvar) ! 147: end ! 148: | oldvar as OVLDvar _ => Env.add(index,strg,VARbind oldvar) ! 149: | _ => impossible "Misc.dumpStructures.rebind") ! 150: | rebind(index,strg,STRbind(strvar)) = ! 151: let val oldstrvar as STRvar{name as [n],binding,...} = ! 152: strApplied(strvar,{path=p,strenv=env},[symbol strg]) ! 153: val newstrvar = STRvar{access=LVAR(namedLvar n), ! 154: name=name, ! 155: binding=binding} ! 156: val strb = STRB{strvar=newstrvar, ! 157: def=VARstr oldstrvar, ! 158: thin=NONE, ! 159: constraint=NONE} ! 160: in strbs := strb :: !strbs; ! 161: Env.add(index,strg,STRbind newstrvar) ! 162: end ! 163: | rebind(index,strg,TYCbind(reftyc as ref tycon)) = ! 164: let val reftyc = case tycon ! 165: of INDtyc i => ! 166: (case env ! 167: of REL{t,...} => ref(t sub i) ! 168: | DIR => impossible "dumpStructure.rebind") ! 169: | SHRtyc p => ref(getEpathTyc(p,env)) ! 170: | _ => reftyc ! 171: val tb = TB{tyc = reftyc, def = CONty(reftyc,[])} ! 172: (* bogus args in def field *) ! 173: in tbs := tb :: !tbs; ! 174: Env.add(index,strg,TYCbind reftyc) ! 175: end ! 176: | rebind(index,strg,CONbind(dcon)) = ! 177: let val olddcon as DATACON{name,const,typ,rep,sign} = ! 178: dconApplied(dcon,{path=p,strenv=env}) ! 179: in case rep ! 180: of VARIABLE _ => ! 181: let val newdcon = ! 182: DATACON{name=name,const=const,typ=ref(!typ),sign=sign, ! 183: rep=VARIABLE(LVAR(namedLvar(name)))} ! 184: val eb = EBdef{exn=newdcon,edef=olddcon} ! 185: in ebs := eb :: !ebs; ! 186: Env.add(index,strg,CONbind newdcon) ! 187: end ! 188: | _ => Env.add(index,strg,CONbind olddcon) ! 189: end ! 190: | rebind(index,strg,FIXbind(fixvar)) = ! 191: Env.add(index,strg,FIXbind fixvar) ! 192: | rebind _ = () ! 193: in IntStrMap.app rebind table; ! 194: SEQdec [STRdec(!strbs),TYPEdec(!tbs),EXCEPTIONdec(!ebs),VALdec(!vbs)] ! 195: end ! 196: | dumpStructure _ = impossible "Misc.dumpStructure" ! 197: ! 198: end (* structure Misc *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.