Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/Elaborator/elaborate/elabutil.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Elaborator/elaborate/elabutil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1332 - (view) (download)

1 : blume 902 (* Copyright 1992 by AT&T Bell Laboratories *)
2 :     (* elabutil.sml *)
3 :    
4 :     structure ElabUtil : ELABUTIL =
5 :     struct
6 :    
7 :     local structure SP = SymPath
8 :     structure LU = Lookup
9 :     structure A = Access
10 :     (* structure II = InlInfo *)
11 :     structure B = Bindings
12 :     structure SE = StaticEnv
13 :     structure EE = EntityEnv
14 :     structure TS = TyvarSet
15 :     structure S = Symbol
16 :     structure V = VarCon
17 :     structure BT = BasicTypes
18 :    
19 :     open Symbol Absyn Ast ErrorMsg PrintUtil AstUtil Types BasicTypes
20 :     EqTypes ModuleUtil TypesUtil VarCon
21 :    
22 :     in
23 :    
24 :     (* debugging *)
25 :     val say = Control_Print.say
26 :     val debugging = ref false
27 :     fun debugmsg (msg: string) =
28 :     if !debugging then (say msg; say "\n") else ()
29 :    
30 :     fun bug msg = ErrorMsg.impossible("ElabUtil: "^msg)
31 :    
32 :     fun for l f = app f l
33 :     fun discard _ = ()
34 :     fun single x = [x]
35 :    
36 :     val internalSym = SpecialSymbols.internalVarId
37 :    
38 :     (* elaboration context *)
39 :    
40 :     datatype context
41 :     = TOP (* at top level -- not inside any module, rigid *)
42 :     | INSTR (* inside a rigid structure, i.e. not inside any functor body *)
43 :    
44 :     | INFCT of {flex: Stamps.stamp -> bool, depth: DebIndex.depth}
45 :     (* within functor body *)
46 :     | INSIG (* within a signature body *)
47 :    
48 :     type compInfo = Absyn.dec CompInfo.compInfo
49 :    
50 :     fun newVALvar(s, mkv) = V.mkVALvar(s, A.namedAcc(s, mkv))
51 :    
52 :     fun smash f l =
53 :     let fun h(a,(pl,oldl,newl)) =
54 :     let val (p,old,new) = f a
55 :     in (p::pl,old@oldl,new@newl)
56 :     end
57 :     in foldr h (nil,nil,nil) l
58 :     end
59 :    
60 :     local
61 :     fun uniq ((a0 as (a,_,_))::(r as (b,_,_)::_)) =
62 :     if S.eq(a,b) then uniq r else a0::uniq r
63 :     | uniq l = l
64 :     fun gtr ((a,_,_), (b,_,_)) = let
65 :     val a' = S.name a and b' = S.name b
66 :     val a0 = String.sub(a',0) and b0 = String.sub(b',0)
67 :     in
68 :     if Char.isDigit a0
69 :     then if Char.isDigit b0
70 :     then size a' > size b' orelse size a' = size b' andalso a' > b'
71 :     else false
72 :     else if Char.isDigit b0
73 :     then true
74 :     else (a' > b')
75 :     end
76 :     in fun sort3 x = uniq (ListMergeSort.sort gtr x)
77 :     end
78 :    
79 :     val EQUALsym = S.varSymbol "="
80 :     val anonParamName = S.strSymbol "<AnonParam>"
81 :    
82 :     (* following could go in Absyn *)
83 :     val bogusID = S.varSymbol "*bogus*"
84 :     val bogusExnID = S.varSymbol "*Bogus*"
85 :    
86 :    
87 :     val TRUEpat = CONpat(trueDcon,[])
88 :     val TRUEexp = CONexp(trueDcon,[])
89 :     val FALSEpat = CONpat(falseDcon,[])
90 :     val FALSEexp = CONexp(falseDcon,[])
91 :    
92 :     val NILpat = CONpat(nilDcon,[])
93 :     val NILexp = CONexp(nilDcon,[])
94 :     val CONSpat = fn pat => APPpat(consDcon,[],pat)
95 :     val CONSexp = CONexp(consDcon,[])
96 :    
97 : blume 903 val unitExp = AbsynUtil.unitExp
98 : blume 902 val unitPat = RECORDpat{fields = nil, flex = false, typ = ref UNDEFty}
99 :     val bogusExp = VARexp(ref(V.mkVALvar(bogusID, A.nullAcc)), [])
100 :    
101 :     (* Verifies that all the elements of a list are unique *)
102 :     fun checkUniq (err,message,names) =
103 :     let val names' = ListMergeSort.sort S.symbolGt names
104 :     fun f (x::y::rest) = (
105 :     if S.eq(x,y)
106 :     then err COMPLAIN (message^ ": " ^ S.name x) nullErrorBody
107 :     else ();
108 :     f(y::rest))
109 :     | f _ = ()
110 :     in f names'
111 :     end
112 :    
113 :     (*
114 :     * Extract all the variables from a pattern
115 :     * NOTE: the "freeOrVars" function in elabcore.sml should probably
116 :     * be merged with this.
117 :     *)
118 :     fun bindVARp (patlist,err) =
119 :     let val vl = ref (nil: symbol list)
120 :     val env = ref(SE.empty: SE.staticEnv)
121 :     fun f (VARpat(v as VALvar{path=SP.SPATH[name],info,...})) =
122 :     (if S.eq(name, EQUALsym) (*** major hack ***)
123 :     then (* if InlInfo.isPrimInfo(InlInfo.fromExn info) then ()
124 :     else *) err WARN "rebinding =" nullErrorBody
125 :     else ();
126 :     env := SE.bind(name,B.VALbind v,!env);
127 :     vl := name :: !vl)
128 :     | f (RECORDpat{fields,...}) = app(fn(_,pat)=>f pat) fields
129 :     | f (VECTORpat(pats,_)) = app f pats
130 :     | f (APPpat(_,_,pat)) = f pat
131 :     | f (CONSTRAINTpat(pat,_)) = f pat
132 :     | f (LAYEREDpat(p1,p2)) = (f p1; f p2)
133 :     | f (ORpat(p1, p2)) = (f p1; bindVARp([p2], err); ())
134 :     | f _ = ()
135 :     in app f patlist;
136 :     checkUniq (err,"duplicate variable in pattern(s)",!vl);
137 :     !env
138 :     end
139 :    
140 :     (*
141 :     fun isPrimPat (VARpat{info, ...}) = II.isPrimInfo(info)
142 :     | isPrimPat (COSTRAINTpat(VARpat{info, ...}, _)) = II.isPrimInfo(info)
143 :     | isPrimPat _ = false
144 :     *)
145 :    
146 :     (* patproc:
147 :     * "alpha convert" a pattern, replacing old variables by
148 :     * new ones, with new LVAR accesses.
149 :     * Returns the converted pattern, the list of old variables (VARpats)
150 :     * and the list of new variables (VALvars).
151 :     * called only once, in elabVB in elabcore.sml *)
152 :    
153 :     fun patproc (pp, compInfo as {mkLvar=mkv, ...} : compInfo) =
154 :     let val oldnew : (Absyn.pat * var) list ref = ref nil
155 :    
156 :     fun f (p as VARpat(VALvar{access=acc,info,typ=ref typ',path})) =
157 :     let fun find ((VARpat(VALvar{access=acc',...}), x)::rest, v) =
158 :     (case (A.accLvar acc') (* DBM: can this return NONE? *)
159 :     of SOME w => if v=w then x else find(rest, v)
160 :     (* DBM: can the true branch happen?
161 :     ie. two variables with same lvar
162 :     in a pattern? *)
163 :     | _ => find(rest, v))
164 :     | find (_::rest, v) = find(rest, v)
165 :     | find (nil, v) = (* DBM: assert this rule always applies ? *)
166 :     let val x = VALvar{access=A.dupAcc(v,mkv), info=info,
167 :     typ=ref typ', path=path}
168 :     in oldnew := (p,x):: !oldnew; x
169 :     end
170 :    
171 :     in (case A.accLvar(acc)
172 :     of SOME v => VARpat(find(!oldnew, v))
173 :     | _ => bug "unexpected access in patproc")
174 :     end
175 :     | f (RECORDpat{fields,flex,typ}) =
176 :     RECORDpat{fields=map (fn(l,p)=>(l,f p)) fields,
177 :     flex=flex, typ=typ}
178 :     | f (VECTORpat(pats,t)) = VECTORpat(map f pats, t)
179 :     | f (APPpat(d,c,p)) = APPpat(d,c,f p)
180 :     | f (ORpat(a,b)) = ORpat(f a, f b)
181 :     | f (CONSTRAINTpat(p,t)) = CONSTRAINTpat(f p, t)
182 :     | f (LAYEREDpat(p,q)) = LAYEREDpat(f p, f q)
183 :     | f p = p
184 :    
185 :     val np = f pp
186 :    
187 :     fun h((a,b)::r, x, y) = h(r, a::x, b::y)
188 :     | h([], x, y) = (np, x, y)
189 :    
190 :     in h (!oldnew, [], [])
191 :     end
192 :    
193 :     (* sort the labels in a record the order is redefined to take the usual
194 :     ordering on numbers expressed by strings (tuples) *)
195 :    
196 :     local
197 :     fun sort x =
198 :     ListMergeSort.sort (fn ((a,_),(b,_)) => TypesUtil.gtLabel (a,b)) x
199 :     in fun sortRecord(l,err) =
200 :     (checkUniq(err, "duplicate label in record",map #1 l);
201 :     sort l)
202 :     end
203 :    
204 :     fun makeRECORDexp(fields,err) =
205 :     let val fields' = map (fn(id,exp)=> (id,(exp,ref 0))) fields
206 :     fun assign(i,(_,(_,r))::tl) = (r := i; assign(i+1,tl))
207 :     | assign(_,nil) = ()
208 :     fun f(i,(id,(exp,ref n))::r) = (LABEL{name=id,number=n},exp)::f(i+1,r)
209 :     | f(_,nil) = nil
210 :     in assign(0, sortRecord(fields',err)); RECORDexp(f(0,fields'))
211 :     end
212 :    
213 : blume 903 val TUPLEexp = AbsynUtil.TUPLEexp
214 :     (*
215 : blume 902 fun TUPLEexp l =
216 :     let fun addlabels(i,e::r) =
217 :     (LABEL{number=i-1,name=(Tuples.numlabel i)},e)
218 :     :: addlabels(i+1,r)
219 :     | addlabels(_, nil) = nil
220 :     in RECORDexp (addlabels(1,l))
221 :     end
222 : blume 903 *)
223 : blume 902
224 :     fun TPSELexp(e, i) =
225 :     let val lab = LABEL{number=i-1, name=(Tuples.numlabel i)}
226 :     in SELECTexp(lab, e)
227 :     end
228 :    
229 :     (* Adds a default case to a list of rules.
230 :     If given list is marked, all ordinarily-marked expressions
231 :     in default case are also marked, using end of given list
232 :     as location.
233 :     KLUDGE! The debugger distinguishes marks in the default case by
234 :     the fact that start and end locations for these marks
235 :     are the same! *)
236 :     fun completeMatch'' rule [r as RULE(pat,MARKexp(_,(left,_)))] =
237 :     [r, rule (fn exp => MARKexp(exp,(left,left)))]
238 :     | completeMatch'' rule
239 :     [r as RULE(pat,CONSTRAINTexp(MARKexp(_,(left,_)),_))] =
240 :     [r, rule (fn exp => MARKexp(exp,(left,left)))]
241 :     | completeMatch'' rule [r] = [r,rule (fn exp => exp)]
242 :     | completeMatch'' rule (a::r) = a :: completeMatch'' rule r
243 :     | completeMatch'' _ _ = bug "completeMatch''"
244 :    
245 :     fun completeMatch' (RULE(p,e)) =
246 :     completeMatch'' (fn marker => RULE(p,marker e))
247 :    
248 :     fun completeMatch(env,name) =
249 :     completeMatch''
250 :     (fn marker =>
251 :     RULE(WILDpat,
252 : blume 903 marker(RAISEexp(CONexp(CoreAccess.getExn(env,name),[]),
253 :     UNDEFty))))
254 : blume 902
255 :     val trivialCompleteMatch = completeMatch(SE.empty,"Match")
256 :    
257 : blume 903 val TUPLEpat = AbsynUtil.TUPLEpat
258 :     (*
259 : blume 902 fun TUPLEpat l =
260 :     let fun addlabels(i,e::r) = (Tuples.numlabel i, e) :: addlabels(i+1, r)
261 :     | addlabels(_, nil) = nil
262 :     in RECORDpat{fields=addlabels(1,l), flex=false, typ=ref UNDEFty}
263 :     end
264 : blume 903 *)
265 : blume 902
266 :     fun wrapRECdecGen (rvbs, compInfo as {mkLvar=mkv, ...} : compInfo) =
267 : mblume 1332 let fun g (RVB{var=v as VALvar{path=SP.SPATH [sym], ...}, ...}, nvars) =
268 : blume 902 let val nv = newVALvar(sym, mkv)
269 :     in ((v, nv, sym)::nvars)
270 :     end
271 :     | g _ = bug "wrapRECdecGen:RVB"
272 :     val vars = foldr g [] rvbs
273 :     val odec = VALRECdec rvbs
274 :    
275 :     val tyvars =
276 :     case rvbs
277 :     of (RVB{tyvars,...})::_ => tyvars
278 :     | _ => bug "unexpected empty rvbs list in wrapRECdecGen"
279 :    
280 :     in (vars,
281 :     case vars
282 :     of [(v, nv, sym)] =>
283 :     (VALdec [VB{pat=VARpat nv, boundtvs=[], tyvars=tyvars,
284 :     exp=LETexp(odec, VARexp(ref v, []))}])
285 :     | _ =>
286 :     (let val vs = map (fn (v, _, _) => VARexp(ref v, [])) vars
287 :     val rootv = newVALvar(internalSym, mkv)
288 :     val rvexp = VARexp(ref rootv, [])
289 :     val nvdec =
290 :     VALdec([VB{pat=VARpat rootv, boundtvs=[], tyvars=tyvars,
291 :     exp=LETexp(odec, TUPLEexp vs)}])
292 :    
293 :     fun h([], _, d) =
294 :     LOCALdec(nvdec, SEQdec(rev d))
295 :     | h((_,nv,_)::r, i, d) =
296 :     let val nvb = VB{pat=VARpat nv, boundtvs=[],
297 :     exp=TPSELexp(rvexp,i),tyvars=ref []}
298 :     in h(r, i+1, VALdec([nvb])::d)
299 :     end
300 :     in h(vars, 1, [])
301 :     end))
302 :     end
303 :    
304 :     fun wrapRECdec0 (rvbs, compInfo) =
305 :     let val (vars, ndec) = wrapRECdecGen(rvbs, compInfo)
306 :     in case vars
307 :     of [(_, nv, _)] => (nv, ndec)
308 :     | _ => bug "unexpected case in wrapRECdec0"
309 :     end
310 :    
311 :     fun wrapRECdec (rvbs, compInfo) =
312 :     let val (vars, ndec) = wrapRECdecGen(rvbs, compInfo)
313 :     fun h((v, nv, sym), env) = SE.bind(sym, B.VALbind nv, env)
314 :     val nenv = foldl h SE.empty vars
315 :     in (ndec, nenv)
316 :     end
317 :    
318 :     val argVarSym = S.varSymbol "arg"
319 :    
320 :     fun FUNdec (completeMatch, fbl, region,
321 :     compInfo as {mkLvar=mkv,errorMatch,...}: compInfo) =
322 :     let fun fb2rvb ({var, clauses as ({pats,resultty,exp}::_),tyvars}) =
323 :     let fun getvar _ = newVALvar(argVarSym, mkv)
324 :     val vars = map getvar pats
325 :     fun not1(f,[a]) = a
326 :     | not1(f,l) = f l
327 :     fun dovar valvar = VARexp(ref(valvar),[])
328 :     fun doclause ({pats,exp,resultty=NONE}) =
329 :     RULE(not1(TUPLEpat,pats), exp)
330 :     | doclause ({pats,exp,resultty=SOME ty}) =
331 :     RULE(not1(TUPLEpat,pats),CONSTRAINTexp(exp,ty))
332 :    
333 :     val mark = case (hd clauses, List.last clauses)
334 :     of ({exp=MARKexp(_,(a,_)),...},
335 :     {exp=MARKexp(_,(_,b)),...}) =>
336 :     (fn e => MARKexp(e,(a,b)))
337 :     | _ => fn e => e
338 :     fun makeexp [var] =
339 :     FNexp(completeMatch(map doclause clauses),UNDEFty)
340 :     | makeexp vars =
341 :     foldr (fn (w,e) =>
342 :     FNexp(completeMatch [RULE(VARpat w,mark e)],
343 :     UNDEFty))
344 :     (CASEexp(TUPLEexp(map dovar vars),
345 :     completeMatch (map doclause clauses),
346 :     true))
347 :     vars
348 :     in RVB {var=var,
349 :     exp=makeexp vars,
350 :     boundtvs=[],
351 :     resultty=NONE,
352 :     tyvars=tyvars}
353 :     end
354 :     | fb2rvb _ = bug "FUNdec"
355 :     in wrapRECdec (map fb2rvb fbl, compInfo)
356 :     end
357 :    
358 :     fun makeHANDLEexp(exp, rules, compInfo as {mkLvar=mkv, ...}: compInfo) =
359 :     let val v = newVALvar(exnID, mkv)
360 :     val r = RULE(VARpat v, RAISEexp(VARexp(ref(v),[]),UNDEFty))
361 :     val rules = completeMatch' r rules
362 :     in HANDLEexp(exp, HANDLER(FNexp(rules,UNDEFty)))
363 :     end
364 :    
365 :    
366 :     (* transform a VarPat into either a variable or a constructor. If we are given
367 :     a long path (>1) then it has to be a constructor. *)
368 :    
369 :     fun pat_id (spath, env, err, compInfo as {mkLvar=mkv, ...}: compInfo) =
370 :     case spath
371 :     of SymPath.SPATH[id] =>
372 :     ((case LU.lookValSym (env,id,fn _ => raise SE.Unbound)
373 :     of V.CON c => CONpat(c,[])
374 :     | _ => VARpat(newVALvar(id,mkv)))
375 :     handle SE.Unbound => VARpat(newVALvar(id,mkv)))
376 :     | _ =>
377 :     CONpat((case LU.lookVal (env,spath,err)
378 :     of V.VAL c =>
379 :     (err COMPLAIN
380 :     ("variable found where constructor is required: "^
381 :     SymPath.toString spath)
382 :     nullErrorBody;
383 :     (bogusCON,[]))
384 :     | V.CON c => (c,[]))
385 :     handle SE.Unbound => bug "unbound untrapped")
386 :    
387 :     fun makeRECORDpat(l,flex,err) =
388 :     RECORDpat{fields=sortRecord(l,err), flex=flex, typ=ref UNDEFty}
389 :    
390 :     fun clean_pat err (CONpat(DATACON{const=false,name,...},_)) =
391 :     (err COMPLAIN ("data constructor "^S.name name^
392 :     " used without argument in pattern")
393 :     nullErrorBody;
394 :     WILDpat)
395 :     | clean_pat err (p as CONpat(DATACON{lazyp=true,...},_)) =
396 :     APPpat(BT.dollarDcon,[],p) (* LAZY *) (* second argument = nil OK? *)
397 :     | clean_pat err p = p
398 :    
399 :     fun pat_to_string WILDpat = "_"
400 :     | pat_to_string (VARpat(VALvar{path,...})) = SP.toString path
401 :     | pat_to_string (CONpat(DATACON{name,...},_)) = S.name name
402 :     | pat_to_string (INTpat(i,_)) = IntInf.toString i
403 :     | pat_to_string (REALpat s) = s
404 :     | pat_to_string (STRINGpat s) = s
405 :     | pat_to_string (CHARpat s) = "#"^s
406 :     | pat_to_string (RECORDpat _) = "<record>"
407 :     | pat_to_string (APPpat _) = "<application>"
408 :     | pat_to_string (CONSTRAINTpat _) = "<constraint pattern>"
409 :     | pat_to_string (LAYEREDpat _) = "<layered pattern>"
410 :     | pat_to_string (VECTORpat _) = "<vector pattern>"
411 :     | pat_to_string (ORpat _) = "<or pattern>"
412 :     | pat_to_string _ = "<illegal pattern>"
413 :    
414 :     fun makeAPPpat err (CONpat(d as DATACON{const=false,lazyp,...},t),p) =
415 :     let val p1 = APPpat(d,t,p)
416 :     in if lazyp (* LAZY *)
417 :     then APPpat(BT.dollarDcon, [], p1)
418 :     else p1
419 :     end
420 :     | makeAPPpat err (CONpat(d as DATACON{name,...},_),_) =
421 :     (err COMPLAIN
422 :     ("constant constructor applied to argument in pattern:"
423 :     ^ S.name name)
424 :     nullErrorBody;
425 :     WILDpat)
426 :     | makeAPPpat err (rator,_) =
427 :     (err COMPLAIN (concat["non-constructor applied to argument in pattern: ",
428 :     pat_to_string rator])
429 :     nullErrorBody;
430 :     WILDpat)
431 :    
432 :     fun makeLAYEREDpat ((x as VARpat _), y, _) = LAYEREDpat(x,y)
433 :     | makeLAYEREDpat (CONSTRAINTpat(x,t), y, err) =
434 :     makeLAYEREDpat(x,CONSTRAINTpat(y,t),err)
435 :     | makeLAYEREDpat (x,y,err) =
436 :     (err COMPLAIN "pattern to left of \"as\" must be variable" nullErrorBody;
437 :     y)
438 :    
439 :     fun calc_strictness (arity, body) =
440 :     let val argument_found = Array.array(arity,false)
441 :     fun search(VARty(ref(INSTANTIATED ty))) = search ty
442 :     | search(IBOUND n) = Array.update(argument_found,n,true)
443 :     | search(CONty(tycon, args)) = app search args
444 :     | search _ = () (* for now... *)
445 :     in search body;
446 :     Array.foldr (op ::) nil argument_found
447 :     end
448 :    
449 :    
450 :     (* checkBoundTyvars: check whether the tyvars appearing in a type (used) are
451 :     bound (as parameters in a type declaration) *)
452 :     fun checkBoundTyvars(used,bound,err) =
453 :     let val boundset =
454 :     foldr (fn (v,s) => TS.union(TS.singleton v,s,err))
455 :     TS.empty bound
456 :     fun nasty(ref(INSTANTIATED(VARty v))) = nasty v
457 :     | nasty(ubound as ref(UBOUND _)) =
458 :     err COMPLAIN ("unbound type variable in type declaration: " ^
459 :     (PPType.tyvarPrintname ubound))
460 :     nullErrorBody
461 :     | nasty _ = bug "checkBoundTyvars"
462 :     in app nasty (TS.elements(TS.diff(used, boundset, err)))
463 :     end
464 :    
465 :     (* labsym : Absyn.numberedLabel -> Symbol.symbol *)
466 :     fun labsym (LABEL{name, ...}) = name
467 :    
468 :     exception IsRec
469 :    
470 :     (** formerly defined in translate/nonrec.sml; now done during type checking *)
471 :     fun recDecs (rvbs as [RVB {var as V.VALvar{access=A.LVAR v, ...},
472 :     exp, resultty, tyvars, boundtvs}]) =
473 :     let fun findexp e =
474 :     (case e
475 :     of VARexp (ref(V.VALvar{access=A.LVAR x, ...}), _) =>
476 :     if v=x then raise IsRec else ()
477 : mblume 1332 | VARexp _ => ()
478 : blume 902 | RECORDexp l => app (fn (lab, x)=>findexp x) l
479 :     | SEQexp l => app findexp l
480 :     | APPexp (a,b) => (findexp a; findexp b)
481 :     | CONSTRAINTexp (x,_) => findexp x
482 :     | HANDLEexp (x, HANDLER h) => (findexp x; findexp h)
483 :     | RAISEexp (x, _) => findexp x
484 :     | LETexp (d, x) => (finddec d; findexp x)
485 :     | CASEexp (x, l, _) =>
486 :     (findexp x; app (fn RULE (_, x) => findexp x) l)
487 : mblume 1332 | IFexp { test, thenCase, elseCase } =>
488 :     (findexp test; findexp thenCase; findexp elseCase)
489 :     | (ANDALSOexp (e1, e2) | ORELSEexp (e1, e2) |
490 :     WHILEexp { test = e1, expr = e2 }) =>
491 :     (findexp e1; findexp e2)
492 : blume 902 | FNexp (l, _) => app (fn RULE (_, x) => findexp x) l
493 :     | MARKexp (x, _) => findexp x
494 : mblume 1332 | SELECTexp (_, e) => findexp e
495 :     | VECTORexp (el, _) => app findexp el
496 :     | PACKexp (e, _, _) => findexp e
497 :     | (CONexp _ | INTexp _ | WORDexp _ | REALexp _ | STRINGexp _ |
498 :     CHARexp _) => ())
499 : blume 902
500 :     and finddec d =
501 :     (case d
502 :     of VALdec vbl => app (fn (VB{exp,...}) => findexp exp) vbl
503 :     | VALRECdec rvbl => app (fn(RVB{exp,...})=>findexp exp) rvbl
504 :     | LOCALdec (a,b) => (finddec a; finddec b)
505 :     | SEQdec l => app finddec l
506 :     | ABSTYPEdec {body, ...} => finddec body
507 :     | MARKdec (dec,_) => finddec dec
508 :     | _ => ())
509 :    
510 :     in (findexp exp;
511 :     VALdec [VB{pat=VARpat var, tyvars=tyvars, boundtvs=boundtvs,
512 :     exp = case resultty
513 :     of SOME ty => CONSTRAINTexp(exp,ty)
514 :     | NONE => exp}])
515 :     handle IsRec => VALRECdec rvbs
516 :     end
517 :    
518 :     | recDecs rvbs = VALRECdec rvbs
519 :    
520 :    
521 :     (* hasModules tests whether there are explicit module declarations in a decl.
522 :     * This is used in elabMod when elaborating LOCALdec as a cheap
523 :     * approximate check of whether a declaration contains any functor
524 :     * declarations. *)
525 :     fun hasModules(StrDec _) = true
526 :     | hasModules(AbsDec _) = true
527 :     | hasModules(FctDec _) = true
528 :     | hasModules(LocalDec(dec_in,dec_out)) =
529 :     hasModules dec_in orelse hasModules dec_out
530 :     | hasModules(SeqDec decs) =
531 :     List.exists hasModules decs
532 :     | hasModules(MarkDec(dec,_)) = hasModules dec
533 :     | hasModules _ = false
534 :    
535 :    
536 :     end (* top-level local *)
537 :     end (* structure ElabUtil *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0