![[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.