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/compiler/Elaborator/elaborate/elabutil.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2624 - (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 : dbm 2492 val TRUEpat = CONpat(trueDcon,[])
88 : blume 902 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 : dbm 2492 fun f (VARpat(v as VALvar{path=SP.SPATH[name],...})) =
122 :     (if S.eq(name, EQUALsym)
123 :     then err WARN "rebinding =" nullErrorBody
124 : blume 902 else ();
125 :     env := SE.bind(name,B.VALbind v,!env);
126 :     vl := name :: !vl)
127 :     | f (RECORDpat{fields,...}) = app(fn(_,pat)=>f pat) fields
128 :     | f (VECTORpat(pats,_)) = app f pats
129 :     | f (APPpat(_,_,pat)) = f pat
130 :     | f (CONSTRAINTpat(pat,_)) = f pat
131 :     | f (LAYEREDpat(p1,p2)) = (f p1; f p2)
132 :     | f (ORpat(p1, p2)) = (f p1; bindVARp([p2], err); ())
133 :     | f _ = ()
134 :     in app f patlist;
135 :     checkUniq (err,"duplicate variable in pattern(s)",!vl);
136 :     !env
137 :     end
138 :    
139 :     (*
140 :     fun isPrimPat (VARpat{info, ...}) = II.isPrimInfo(info)
141 :     | isPrimPat (COSTRAINTpat(VARpat{info, ...}, _)) = II.isPrimInfo(info)
142 :     | isPrimPat _ = false
143 :     *)
144 :    
145 :     (* patproc:
146 :     * "alpha convert" a pattern, replacing old variables by
147 :     * new ones, with new LVAR accesses.
148 :     * Returns the converted pattern, the list of old variables (VARpats)
149 :     * and the list of new variables (VALvars).
150 :     * called only once, in elabVB in elabcore.sml *)
151 :    
152 :     fun patproc (pp, compInfo as {mkLvar=mkv, ...} : compInfo) =
153 :     let val oldnew : (Absyn.pat * var) list ref = ref nil
154 :    
155 : dbm 2492 fun f (p as VARpat(VALvar{access=acc,prim,typ=ref typ',path})) =
156 : blume 902 let fun find ((VARpat(VALvar{access=acc',...}), x)::rest, v) =
157 :     (case (A.accLvar acc') (* DBM: can this return NONE? *)
158 :     of SOME w => if v=w then x else find(rest, v)
159 :     (* DBM: can the true branch happen?
160 :     ie. two variables with same lvar
161 :     in a pattern? *)
162 :     | _ => find(rest, v))
163 :     | find (_::rest, v) = find(rest, v)
164 :     | find (nil, v) = (* DBM: assert this rule always applies ? *)
165 : dbm 2492 let val x = VALvar{access=A.dupAcc(v,mkv), prim=prim,
166 : blume 902 typ=ref typ', path=path}
167 :     in oldnew := (p,x):: !oldnew; x
168 :     end
169 :    
170 :     in (case A.accLvar(acc)
171 :     of SOME v => VARpat(find(!oldnew, v))
172 :     | _ => bug "unexpected access in patproc")
173 :     end
174 :     | f (RECORDpat{fields,flex,typ}) =
175 :     RECORDpat{fields=map (fn(l,p)=>(l,f p)) fields,
176 :     flex=flex, typ=typ}
177 :     | f (VECTORpat(pats,t)) = VECTORpat(map f pats, t)
178 :     | f (APPpat(d,c,p)) = APPpat(d,c,f p)
179 :     | f (ORpat(a,b)) = ORpat(f a, f b)
180 :     | f (CONSTRAINTpat(p,t)) = CONSTRAINTpat(f p, t)
181 :     | f (LAYEREDpat(p,q)) = LAYEREDpat(f p, f q)
182 :     | f p = p
183 :    
184 :     val np = f pp
185 :    
186 :     fun h((a,b)::r, x, y) = h(r, a::x, b::y)
187 :     | h([], x, y) = (np, x, y)
188 :    
189 :     in h (!oldnew, [], [])
190 :     end
191 :    
192 :     (* sort the labels in a record the order is redefined to take the usual
193 :     ordering on numbers expressed by strings (tuples) *)
194 :    
195 :     local
196 :     fun sort x =
197 :     ListMergeSort.sort (fn ((a,_),(b,_)) => TypesUtil.gtLabel (a,b)) x
198 :     in fun sortRecord(l,err) =
199 :     (checkUniq(err, "duplicate label in record",map #1 l);
200 :     sort l)
201 :     end
202 :    
203 :     fun makeRECORDexp(fields,err) =
204 :     let val fields' = map (fn(id,exp)=> (id,(exp,ref 0))) fields
205 :     fun assign(i,(_,(_,r))::tl) = (r := i; assign(i+1,tl))
206 :     | assign(_,nil) = ()
207 :     fun f(i,(id,(exp,ref n))::r) = (LABEL{name=id,number=n},exp)::f(i+1,r)
208 :     | f(_,nil) = nil
209 :     in assign(0, sortRecord(fields',err)); RECORDexp(f(0,fields'))
210 :     end
211 :    
212 : blume 903 val TUPLEexp = AbsynUtil.TUPLEexp
213 :     (*
214 : blume 902 fun TUPLEexp l =
215 :     let fun addlabels(i,e::r) =
216 :     (LABEL{number=i-1,name=(Tuples.numlabel i)},e)
217 :     :: addlabels(i+1,r)
218 :     | addlabels(_, nil) = nil
219 :     in RECORDexp (addlabels(1,l))
220 :     end
221 : blume 903 *)
222 : blume 902
223 :     fun TPSELexp(e, i) =
224 :     let val lab = LABEL{number=i-1, name=(Tuples.numlabel i)}
225 :     in SELECTexp(lab, e)
226 :     end
227 :    
228 :     (* Adds a default case to a list of rules.
229 :     If given list is marked, all ordinarily-marked expressions
230 :     in default case are also marked, using end of given list
231 :     as location.
232 :     KLUDGE! The debugger distinguishes marks in the default case by
233 :     the fact that start and end locations for these marks
234 :     are the same! *)
235 : mblume 1648 fun completeMatch'' rule [r as RULE(pat,MARKexp(_,(_,right)))] =
236 :     [r, rule (fn exp => MARKexp(exp,(right,right)))]
237 : blume 902 | completeMatch'' rule
238 : mblume 1648 [r as RULE(pat,CONSTRAINTexp(MARKexp(_,(_,right)),_))] =
239 :     [r, rule (fn exp => MARKexp(exp,(right,right)))]
240 : blume 902 | completeMatch'' rule [r] = [r,rule (fn exp => exp)]
241 :     | completeMatch'' rule (a::r) = a :: completeMatch'' rule r
242 :     | completeMatch'' _ _ = bug "completeMatch''"
243 :    
244 :     fun completeMatch' (RULE(p,e)) =
245 :     completeMatch'' (fn marker => RULE(p,marker e))
246 :    
247 :     fun completeMatch(env,name) =
248 :     completeMatch''
249 :     (fn marker =>
250 :     RULE(WILDpat,
251 : blume 2624 marker(RAISEexp(CONexp(CoreAccess.getExn env [name],[]),
252 : blume 903 UNDEFty))))
253 : dbm 2492 (** Updated to the ty option type - GK *)
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 : dbm 2492 exp=LETexp(odec, VARexp(ref v, []))}])
285 : blume 902 | _ =>
286 : dbm 2492 (let val vs = map (fn (v, _, _) => VARexp(ref v, [])) vars
287 : blume 902 val rootv = newVALvar(internalSym, mkv)
288 : dbm 2492 val rvexp = VARexp(ref rootv, [])
289 : blume 902 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 : mblume 1645 fun cMARKexp (e, r) = if !ElabControl.markabsyn then MARKexp (e, r) else e
321 :    
322 : mblume 1646 fun FUNdec (completeMatch, fbl,
323 :     compInfo as {mkLvar=mkv,errorMatch,...}: compInfo) =
324 : mblume 1645 let fun fb2rvb ({var, clauses as ({pats,resultty,exp}::_),tyvars,region}) =
325 : blume 902 let fun getvar _ = newVALvar(argVarSym, mkv)
326 :     val vars = map getvar pats
327 :     fun not1(f,[a]) = a
328 :     | not1(f,l) = f l
329 : dbm 2492 fun dovar valvar = VARexp(ref(valvar),[])
330 : blume 902 fun doclause ({pats,exp,resultty=NONE}) =
331 :     RULE(not1(TUPLEpat,pats), exp)
332 :     | doclause ({pats,exp,resultty=SOME ty}) =
333 :     RULE(not1(TUPLEpat,pats),CONSTRAINTexp(exp,ty))
334 :    
335 : mblume 1648 (* -- Matthias says: this seems to generate slightly bogus marks:
336 :     *
337 : blume 902 val mark = case (hd clauses, List.last clauses)
338 :     of ({exp=MARKexp(_,(a,_)),...},
339 :     {exp=MARKexp(_,(_,b)),...}) =>
340 :     (fn e => MARKexp(e,(a,b)))
341 :     | _ => fn e => e
342 : mblume 1648 *)
343 : blume 902 fun makeexp [var] =
344 :     FNexp(completeMatch(map doclause clauses),UNDEFty)
345 :     | makeexp vars =
346 :     foldr (fn (w,e) =>
347 : mblume 1648 FNexp(completeMatch [RULE(VARpat w,(*mark*) e)],
348 : blume 902 UNDEFty))
349 :     (CASEexp(TUPLEexp(map dovar vars),
350 :     completeMatch (map doclause clauses),
351 :     true))
352 :     vars
353 :     in RVB {var=var,
354 : mblume 1645 exp=cMARKexp (makeexp vars, region),
355 : blume 902 boundtvs=[],
356 :     resultty=NONE,
357 :     tyvars=tyvars}
358 :     end
359 :     | fb2rvb _ = bug "FUNdec"
360 :     in wrapRECdec (map fb2rvb fbl, compInfo)
361 :     end
362 :    
363 :     fun makeHANDLEexp(exp, rules, compInfo as {mkLvar=mkv, ...}: compInfo) =
364 :     let val v = newVALvar(exnID, mkv)
365 : dbm 2492 val r = RULE(VARpat v, RAISEexp(VARexp(ref(v),[]),UNDEFty)) (** Updated to the ty option type - GK*)
366 : blume 902 val rules = completeMatch' r rules
367 : mblume 1641 in HANDLEexp(exp, (rules,UNDEFty))
368 : blume 902 end
369 :    
370 :    
371 :     (* transform a VarPat into either a variable or a constructor. If we are given
372 :     a long path (>1) then it has to be a constructor. *)
373 :    
374 :     fun pat_id (spath, env, err, compInfo as {mkLvar=mkv, ...}: compInfo) =
375 :     case spath
376 :     of SymPath.SPATH[id] =>
377 :     ((case LU.lookValSym (env,id,fn _ => raise SE.Unbound)
378 :     of V.CON c => CONpat(c,[])
379 :     | _ => VARpat(newVALvar(id,mkv)))
380 :     handle SE.Unbound => VARpat(newVALvar(id,mkv)))
381 :     | _ =>
382 :     CONpat((case LU.lookVal (env,spath,err)
383 :     of V.VAL c =>
384 :     (err COMPLAIN
385 :     ("variable found where constructor is required: "^
386 :     SymPath.toString spath)
387 :     nullErrorBody;
388 : dbm 2492 (bogusCON,[]))
389 :     | V.CON c => (c,[]))
390 : blume 902 handle SE.Unbound => bug "unbound untrapped")
391 :    
392 :     fun makeRECORDpat(l,flex,err) =
393 :     RECORDpat{fields=sortRecord(l,err), flex=flex, typ=ref UNDEFty}
394 :    
395 :     fun clean_pat err (CONpat(DATACON{const=false,name,...},_)) =
396 :     (err COMPLAIN ("data constructor "^S.name name^
397 :     " used without argument in pattern")
398 :     nullErrorBody;
399 :     WILDpat)
400 :     | clean_pat err (p as CONpat(DATACON{lazyp=true,...},_)) =
401 :     APPpat(BT.dollarDcon,[],p) (* LAZY *) (* second argument = nil OK? *)
402 :     | clean_pat err p = p
403 :    
404 :     fun pat_to_string WILDpat = "_"
405 :     | pat_to_string (VARpat(VALvar{path,...})) = SP.toString path
406 :     | pat_to_string (CONpat(DATACON{name,...},_)) = S.name name
407 :     | pat_to_string (INTpat(i,_)) = IntInf.toString i
408 :     | pat_to_string (REALpat s) = s
409 :     | pat_to_string (STRINGpat s) = s
410 :     | pat_to_string (CHARpat s) = "#"^s
411 :     | pat_to_string (RECORDpat _) = "<record>"
412 :     | pat_to_string (APPpat _) = "<application>"
413 :     | pat_to_string (CONSTRAINTpat _) = "<constraint pattern>"
414 :     | pat_to_string (LAYEREDpat _) = "<layered pattern>"
415 :     | pat_to_string (VECTORpat _) = "<vector pattern>"
416 :     | pat_to_string (ORpat _) = "<or pattern>"
417 :     | pat_to_string _ = "<illegal pattern>"
418 :    
419 : dbm 2492 fun makeAPPpat err (CONpat(d as DATACON{const=false,lazyp,...},tvs),p) =
420 :     let
421 :     val p1 = APPpat(d, tvs, p)
422 : blume 902 in if lazyp (* LAZY *)
423 :     then APPpat(BT.dollarDcon, [], p1)
424 :     else p1
425 :     end
426 :     | makeAPPpat err (CONpat(d as DATACON{name,...},_),_) =
427 :     (err COMPLAIN
428 :     ("constant constructor applied to argument in pattern:"
429 :     ^ S.name name)
430 :     nullErrorBody;
431 :     WILDpat)
432 :     | makeAPPpat err (rator,_) =
433 :     (err COMPLAIN (concat["non-constructor applied to argument in pattern: ",
434 :     pat_to_string rator])
435 :     nullErrorBody;
436 :     WILDpat)
437 :    
438 :     fun makeLAYEREDpat ((x as VARpat _), y, _) = LAYEREDpat(x,y)
439 :     | makeLAYEREDpat (CONSTRAINTpat(x,t), y, err) =
440 :     makeLAYEREDpat(x,CONSTRAINTpat(y,t),err)
441 :     | makeLAYEREDpat (x,y,err) =
442 :     (err COMPLAIN "pattern to left of \"as\" must be variable" nullErrorBody;
443 :     y)
444 :    
445 :     fun calc_strictness (arity, body) =
446 :     let val argument_found = Array.array(arity,false)
447 :     fun search(VARty(ref(INSTANTIATED ty))) = search ty
448 :     | search(IBOUND n) = Array.update(argument_found,n,true)
449 : dbm 2492 | search(ty as CONty(tycon, args)) =
450 :     (case tycon
451 :     of DEFtyc _ => search(headReduceType ty)
452 :     | _ => app search args)
453 : blume 902 | search _ = () (* for now... *)
454 :     in search body;
455 :     Array.foldr (op ::) nil argument_found
456 :     end
457 :    
458 :    
459 :     (* checkBoundTyvars: check whether the tyvars appearing in a type (used) are
460 :     bound (as parameters in a type declaration) *)
461 :     fun checkBoundTyvars(used,bound,err) =
462 :     let val boundset =
463 :     foldr (fn (v,s) => TS.union(TS.singleton v,s,err))
464 :     TS.empty bound
465 :     fun nasty(ref(INSTANTIATED(VARty v))) = nasty v
466 :     | nasty(ubound as ref(UBOUND _)) =
467 :     err COMPLAIN ("unbound type variable in type declaration: " ^
468 :     (PPType.tyvarPrintname ubound))
469 :     nullErrorBody
470 :     | nasty _ = bug "checkBoundTyvars"
471 :     in app nasty (TS.elements(TS.diff(used, boundset, err)))
472 :     end
473 :    
474 :     (* labsym : Absyn.numberedLabel -> Symbol.symbol *)
475 :     fun labsym (LABEL{name, ...}) = name
476 :    
477 :     exception IsRec
478 :    
479 : dbm 2492 (** FLINT in front end **)
480 : blume 902 (** formerly defined in translate/nonrec.sml; now done during type checking *)
481 :     fun recDecs (rvbs as [RVB {var as V.VALvar{access=A.LVAR v, ...},
482 :     exp, resultty, tyvars, boundtvs}]) =
483 :     let fun findexp e =
484 :     (case e
485 :     of VARexp (ref(V.VALvar{access=A.LVAR x, ...}), _) =>
486 :     if v=x then raise IsRec else ()
487 : mblume 1332 | VARexp _ => ()
488 : blume 902 | RECORDexp l => app (fn (lab, x)=>findexp x) l
489 :     | SEQexp l => app findexp l
490 :     | APPexp (a,b) => (findexp a; findexp b)
491 :     | CONSTRAINTexp (x,_) => findexp x
492 : mblume 1641 | HANDLEexp (x, (l, _)) =>
493 :     (findexp x; app (fn RULE (_, x) => findexp x) l)
494 : blume 902 | RAISEexp (x, _) => findexp x
495 :     | LETexp (d, x) => (finddec d; findexp x)
496 :     | CASEexp (x, l, _) =>
497 :     (findexp x; app (fn RULE (_, x) => findexp x) l)
498 : mblume 1332 | IFexp { test, thenCase, elseCase } =>
499 :     (findexp test; findexp thenCase; findexp elseCase)
500 :     | (ANDALSOexp (e1, e2) | ORELSEexp (e1, e2) |
501 :     WHILEexp { test = e1, expr = e2 }) =>
502 :     (findexp e1; findexp e2)
503 : blume 902 | FNexp (l, _) => app (fn RULE (_, x) => findexp x) l
504 :     | MARKexp (x, _) => findexp x
505 : mblume 1332 | SELECTexp (_, e) => findexp e
506 :     | VECTORexp (el, _) => app findexp el
507 :     | PACKexp (e, _, _) => findexp e
508 :     | (CONexp _ | INTexp _ | WORDexp _ | REALexp _ | STRINGexp _ |
509 :     CHARexp _) => ())
510 : blume 902
511 :     and finddec d =
512 :     (case d
513 :     of VALdec vbl => app (fn (VB{exp,...}) => findexp exp) vbl
514 :     | VALRECdec rvbl => app (fn(RVB{exp,...})=>findexp exp) rvbl
515 :     | LOCALdec (a,b) => (finddec a; finddec b)
516 :     | SEQdec l => app finddec l
517 :     | ABSTYPEdec {body, ...} => finddec body
518 :     | MARKdec (dec,_) => finddec dec
519 :     | _ => ())
520 :    
521 :     in (findexp exp;
522 :     VALdec [VB{pat=VARpat var, tyvars=tyvars, boundtvs=boundtvs,
523 :     exp = case resultty
524 :     of SOME ty => CONSTRAINTexp(exp,ty)
525 :     | NONE => exp}])
526 :     handle IsRec => VALRECdec rvbs
527 :     end
528 :    
529 :     | recDecs rvbs = VALRECdec rvbs
530 :    
531 :    
532 :     (* hasModules tests whether there are explicit module declarations in a decl.
533 :     * This is used in elabMod when elaborating LOCALdec as a cheap
534 :     * approximate check of whether a declaration contains any functor
535 :     * declarations. *)
536 :     fun hasModules(StrDec _) = true
537 :     | hasModules(AbsDec _) = true
538 :     | hasModules(FctDec _) = true
539 :     | hasModules(LocalDec(dec_in,dec_out)) =
540 :     hasModules dec_in orelse hasModules dec_out
541 :     | hasModules(SeqDec decs) =
542 :     List.exists hasModules decs
543 :     | hasModules(MarkDec(dec,_)) = hasModules dec
544 :     | hasModules _ = false
545 :    
546 :    
547 :     end (* top-level local *)
548 :     end (* structure ElabUtil *)

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