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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* 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 :    
18 :     open Symbol Absyn Ast ErrorMsg PrintUtil AstUtil Types BasicTypes
19 :     EqTypes ModuleUtil TypesUtil VarCon
20 :    
21 :     in
22 :    
23 :     (* debugging *)
24 :     val say = Control.Print.say
25 :     val debugging = ref false
26 :     fun debugmsg (msg: string) =
27 :     if !debugging then (say msg; say "\n") else ()
28 :    
29 :     fun bug msg = ErrorMsg.impossible("ElabUtil: "^msg)
30 :    
31 :     fun for l f = app f l
32 :     fun discard _ = ()
33 :     fun single x = [x]
34 :    
35 :     val internalSym = S.varSymbol "<InternalVar>"
36 :    
37 :     (* elaboration context *)
38 :    
39 :     datatype context
40 :     = TOP (* at top level -- not inside any module, rigid *)
41 :     | INSTR (* inside a rigid structure, i.e. not inside any functor body *)
42 :    
43 :     | INFCT of {flex: Stamps.stamp -> bool, depth: DebIndex.depth}
44 :     (* within functor body *)
45 :     | INSIG (* within a signature body *)
46 :    
47 :     type compInfo = CompBasic.compInfo
48 :    
49 :     fun newVALvar(s, mkv) = V.mkVALvar(s, A.namedAcc(s, mkv))
50 :    
51 :     fun smash f l =
52 :     let fun h(a,(pl,oldl,newl)) =
53 :     let val (p,old,new) = f a
54 :     in (p::pl,old@oldl,new@newl)
55 :     end
56 :     in foldr h (nil,nil,nil) l
57 :     end
58 :    
59 :     local
60 :     fun uniq ((a0 as (a,_,_))::(r as (b,_,_)::_)) =
61 :     if S.eq(a,b) then uniq r else a0::uniq r
62 :     | uniq l = l
63 :     fun gtr ((a,_,_), (b,_,_)) = let
64 :     val a' = S.name a and b' = S.name b
65 :     val a0 = String.sub(a',0) and b0 = String.sub(b',0)
66 :     in
67 :     if Char.isDigit a0
68 :     then if Char.isDigit b0
69 :     then size a' > size b' orelse size a' = size b' andalso a' > b'
70 :     else false
71 :     else if Char.isDigit b0
72 :     then true
73 :     else (a' > b')
74 :     end
75 :     in fun sort3 x = uniq (Sort.sort gtr x)
76 :     end
77 :    
78 :     val EQUALsym = S.varSymbol "="
79 :     val anonParamName = S.strSymbol "<AnonParam>"
80 :    
81 :     (* following could go in Absyn *)
82 :     val bogusID = S.varSymbol "*bogus*"
83 :     val bogusExnID = S.varSymbol "*Bogus*"
84 :    
85 :    
86 :     val TRUEpat = CONpat(trueDcon,[])
87 :     val TRUEexp = CONexp(trueDcon,[])
88 :     val FALSEpat = CONpat(falseDcon,[])
89 :     val FALSEexp = CONexp(falseDcon,[])
90 :    
91 :     val NILpat = CONpat(nilDcon,[])
92 :     val NILexp = CONexp(nilDcon,[])
93 :     val CONSpat = fn pat => APPpat(consDcon,[],pat)
94 :     val CONSexp = CONexp(consDcon,[])
95 :    
96 :     val unitExp = RECORDexp nil
97 :     val unitPat = RECORDpat{fields = nil, flex = false, typ = ref UNDEFty}
98 :     val bogusExp = VARexp(ref(V.mkVALvar(bogusID, A.nullAcc)), [])
99 :    
100 :     (* Verifies that all the elements of a list are unique *)
101 :     fun checkUniq (err,message,names) =
102 :     let val names' = Sort.sort S.symbolGt names
103 :     fun f (x::y::rest) = (
104 :     if S.eq(x,y)
105 :     then err COMPLAIN (message^ ": " ^ S.name x) nullErrorBody
106 :     else ();
107 :     f(y::rest))
108 :     | f _ = ()
109 :     in f names'
110 :     end
111 :    
112 :     (*
113 :     * Extract all the variables from a pattern
114 :     * NOTE: the "freeOrVars" function in elabcore.sml should probably
115 :     * be merged with this.
116 :     *)
117 :     fun bindVARp (patlist,err) =
118 :     let val vl = ref (nil: symbol list)
119 :     val env = ref(SE.empty: SE.staticEnv)
120 :     fun f (VARpat(v as VALvar{path=SP.SPATH[name],info,...})) =
121 :     (if S.eq(name, EQUALsym) (*** major hack ***)
122 :     then (if InlInfo.isPrimInfo(info) then ()
123 :     else err WARN "rebinding =" nullErrorBody)
124 :     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 :     fun patproc (pp, compInfo as {mkLvar=mkv, ...} : compInfo) =
145 :     let val oldnew : (Absyn.pat * var) list ref = ref nil
146 :    
147 :     fun f (p as VARpat(VALvar{access=acc,info,typ=ref typ',path})) =
148 :     let fun find ((VARpat(VALvar{access=acc',...}), x)::rest, v) =
149 :     (case (A.accLvar acc')
150 :     of SOME w => if v=w then x else find(rest, v)
151 :     | _ => find(rest, v))
152 :     | find (_::rest, v) = find(rest, v)
153 :     | find (nil, v) =
154 :     let val x = VALvar{access=A.dupAcc(v,mkv), info=info,
155 :     typ=ref typ', path=path}
156 :     in oldnew := (p,x):: !oldnew; x
157 :     end
158 :    
159 :     in (case A.accLvar(acc)
160 :     of SOME v => VARpat(find(!oldnew, v))
161 :     | _ => bug "unexpected access in patproc")
162 :     end
163 :     | f (RECORDpat{fields,flex,typ}) =
164 :     RECORDpat{fields=map (fn(l,p)=>(l,f p)) fields,
165 :     flex=flex, typ=typ}
166 :     | f (VECTORpat(pats,t)) = VECTORpat(map f pats, t)
167 :     | f (APPpat(d,c,p)) = APPpat(d,c,f p)
168 :     | f (ORpat(a,b)) = ORpat(f a, f b)
169 :     | f (CONSTRAINTpat(p,t)) = CONSTRAINTpat(f p, t)
170 :     | f (LAYEREDpat(p,q)) = LAYEREDpat(f p, f q)
171 :     | f p = p
172 :    
173 :     val np = f pp
174 :    
175 :     fun h((a,b)::r, x, y) = h(r, a::x, b::y)
176 :     | h([], x, y) = (np, x, y)
177 :    
178 :     in h (!oldnew, [], [])
179 :     end
180 :    
181 :     (* sort the labels in a record the order is redefined to take the usual
182 :     ordering on numbers expressed by strings (tuples) *)
183 :    
184 :     local
185 :     fun sort x = Sort.sort (fn ((a,_),(b,_)) => TypesUtil.gtLabel (a,b)) x
186 :     in fun sortRecord(l,err) =
187 :     (checkUniq(err, "duplicate label in record",map #1 l);
188 :     sort l)
189 :     end
190 :    
191 :     fun makeRECORDexp(fields,err) =
192 :     let val fields' = map (fn(id,exp)=> (id,(exp,ref 0))) fields
193 :     fun assign(i,(_,(_,r))::tl) = (r := i; assign(i+1,tl))
194 :     | assign(_,nil) = ()
195 :     fun f(i,(id,(exp,ref n))::r) = (LABEL{name=id,number=n},exp)::f(i+1,r)
196 :     | f(_,nil) = nil
197 :     in assign(0, sortRecord(fields',err)); RECORDexp(f(0,fields'))
198 :     end
199 :    
200 :     fun TUPLEexp l =
201 :     let fun addlabels(i,e::r) =
202 :     (LABEL{number=i-1,name=(Tuples.numlabel i)},e)
203 :     :: addlabels(i+1,r)
204 :     | addlabels(_, nil) = nil
205 :     in RECORDexp (addlabels(1,l))
206 :     end
207 :    
208 :     fun TPSELexp(e, i) =
209 :     let val lab = LABEL{number=i-1, name=(Tuples.numlabel i)}
210 :     in SELECTexp(lab, e)
211 :     end
212 :    
213 :     (* Adds a default case to a list of rules.
214 :     If given list is marked, all ordinarily-marked expressions
215 :     in default case are also marked, using end of given list
216 :     as location.
217 :     KLUDGE! The debugger distinguishes marks in the default case by
218 :     the fact that start and end locations for these marks
219 :     are the same! *)
220 :     fun completeMatch'' rule [r as RULE(pat,MARKexp(_,(left,_)))] =
221 :     [r, rule (fn exp => MARKexp(exp,(left,left)))]
222 :     | completeMatch'' rule
223 :     [r as RULE(pat,CONSTRAINTexp(MARKexp(_,(left,_)),_))] =
224 :     [r, rule (fn exp => MARKexp(exp,(left,left)))]
225 :     | completeMatch'' rule [r] = [r,rule (fn exp => exp)]
226 :     | completeMatch'' rule (a::r) = a :: completeMatch'' rule r
227 :     | completeMatch'' _ _ = bug "completeMatch''"
228 :    
229 :     fun completeMatch' (RULE(p,e)) =
230 :     completeMatch'' (fn marker => RULE(p,marker e))
231 :    
232 :     exception NoCore
233 :    
234 :     fun completeMatch(coreEnv,name) =
235 :     let val exnMatch =
236 :     (case LU.lookVal(coreEnv,SP.SPATH[strSymbol "Core", varSymbol name],
237 :     fn _ => fn s => fn _ => raise NoCore)
238 :     of V.CON x => x
239 :     | _ => V.bogusEXN) handle NoCore => V.bogusEXN
240 :     in completeMatch''
241 :     (fn marker =>
242 :     RULE(WILDpat,
243 :     marker(RAISEexp(CONexp(exnMatch,[]), UNDEFty))))
244 :     end
245 :    
246 :     val trivialCompleteMatch = completeMatch(SE.empty,"Match")
247 :    
248 :    
249 :     (* Transform a while loop in a call to a recursive function *)
250 :     val whileSym = S.varSymbol "while"
251 :    
252 :     fun IFexp (a,b,c) =
253 :     CASEexp(a, trivialCompleteMatch [RULE(TRUEpat,b), RULE(FALSEpat,c)],true)
254 :    
255 :     fun TUPLEpat l =
256 :     let fun addlabels(i,e::r) = (Tuples.numlabel i, e) :: addlabels(i+1, r)
257 :     | addlabels(_, nil) = nil
258 :     in RECORDpat{fields=addlabels(1,l), flex=false, typ=ref UNDEFty}
259 :     end
260 :    
261 :     fun wrapRECdecGen (rvbs, compInfo as {mkLvar=mkv, ...} : compInfo) =
262 :     let fun g (RVB{var=v as VALvar{path=SP.SPATH [sym], ...}, ...},
263 :     nvars) =
264 :     let val nv = newVALvar(sym, mkv)
265 :     in ((v, nv, sym)::nvars)
266 :     end
267 :     val vars = foldr g [] rvbs
268 :     val odec = VALRECdec rvbs
269 :    
270 :     val tyvars =
271 :     case rvbs
272 :     of (RVB{tyvars,...})::_ => tyvars
273 :     | _ => bug "unexpected empty rvbs list in wrapRECdecGen"
274 :    
275 :     in (vars,
276 :     case vars
277 :     of [(v, nv, sym)] =>
278 :     (VALdec [VB{pat=VARpat nv, boundtvs=[], tyvars=tyvars,
279 :     exp=LETexp(odec, VARexp(ref v, []))}])
280 :     | _ =>
281 :     (let val vs = map (fn (v, _, _) => VARexp(ref v, [])) vars
282 :     val rootv = newVALvar(internalSym, mkv)
283 :     val rvexp = VARexp(ref rootv, [])
284 :     val nvdec =
285 :     VALdec([VB{pat=VARpat rootv, boundtvs=[], tyvars=tyvars,
286 :     exp=LETexp(odec, TUPLEexp vs)}])
287 :    
288 :     fun h([], _, d) =
289 :     LOCALdec(nvdec, SEQdec(rev d))
290 :     | h((_,nv,_)::r, i, d) =
291 :     let val nvb = VB{pat=VARpat nv, boundtvs=[],
292 :     exp=TPSELexp(rvexp,i),tyvars=ref []}
293 :     in h(r, i+1, VALdec([nvb])::d)
294 :     end
295 :     in h(vars, 1, [])
296 :     end))
297 :     end
298 :    
299 :     fun wrapRECdec0 (rvbs, compInfo) =
300 :     let val (vars, ndec) = wrapRECdecGen(rvbs, compInfo)
301 :     in case vars
302 :     of [(_, nv, _)] => (nv, ndec)
303 :     | _ => bug "unexpected case in wrapRECdec0"
304 :     end
305 :    
306 :     fun wrapRECdec (rvbs, compInfo) =
307 :     let val (vars, ndec) = wrapRECdecGen(rvbs, compInfo)
308 :     fun h((v, nv, sym), env) = Env.bind(sym, B.VALbind nv, env)
309 :     val nenv = foldl h SE.empty vars
310 :     in (ndec, nenv)
311 :     end
312 :    
313 :     val argVarSym = S.varSymbol "arg"
314 :    
315 :     fun FUNdec (completeMatch, fbl, region,
316 :     compInfo as {mkLvar=mkv,errorMatch,...}: compInfo) =
317 :     let fun fb2rvb ({var, clauses as ({pats,resultty,exp}::_),tyvars}) =
318 :     let fun getvar _ = newVALvar(argVarSym, mkv)
319 :     val vars = map getvar pats
320 :     fun not1(f,[a]) = a
321 :     | not1(f,l) = f l
322 :     fun dovar valvar = VARexp(ref(valvar),[])
323 :     fun doclause ({pats,exp,resultty=NONE}) =
324 :     RULE(not1(TUPLEpat,pats), exp)
325 :     | doclause ({pats,exp,resultty=SOME ty}) =
326 :     RULE(not1(TUPLEpat,pats),CONSTRAINTexp(exp,ty))
327 :    
328 :     fun last[x] = x | last (a::r) = last r
329 :     val mark = case (hd clauses, last clauses)
330 :     of ({exp=MARKexp(_,(a,_)),...},
331 :     {exp=MARKexp(_,(_,b)),...}) =>
332 :     (fn e => MARKexp(e,(a,b)))
333 :     | _ => fn e => e
334 :     fun makeexp [var] =
335 :     FNexp(completeMatch(map doclause clauses),UNDEFty)
336 :     | makeexp vars =
337 :     foldr (fn (w,e) =>
338 :     FNexp(completeMatch [RULE(VARpat w,mark e)],
339 :     UNDEFty))
340 :     (CASEexp(TUPLEexp(map dovar vars),
341 :     completeMatch (map doclause clauses),
342 :     true))
343 :     vars
344 :     in RVB {var=var,
345 :     exp=makeexp vars,
346 :     boundtvs=[],
347 :     resultty=NONE,
348 :     tyvars=tyvars}
349 :     end
350 :     | fb2rvb _ = bug "FUNdec"
351 :     in wrapRECdec (map fb2rvb fbl, compInfo)
352 :     end
353 :    
354 :     fun WHILEexp (a, b, compInfo as {mkLvar=mkv, ...} : compInfo) =
355 :     let val fvar = newVALvar(whileSym, mkv)
356 :     val id = fn x => x
357 :     val (markdec,markall,markend,markbody) =
358 :     case (a,b)
359 :     of (MARKexp(_,(a1,a2)), MARKexp(_,(b1,b2))) =>
360 :     (fn e => MARKdec(e,(a1,b2)), fn e => MARKexp(e,(a1,b2)),
361 :     fn e => MARKexp(e,(b2,b2)), fn e => MARKexp(e,(b1,b2)))
362 :     | _ => (id,id,id,id)
363 :     val body =
364 :     markbody(SEQexp[b, APPexp(markend(VARexp(ref fvar,[])),
365 :     markend unitExp)])
366 :     val loop = markall(IFexp(a,body, markend unitExp))
367 :     val fnloop = markall(FNexp(trivialCompleteMatch
368 :     [RULE(unitPat,loop)],UNDEFty))
369 :    
370 :     val (nvar, ndec) =
371 :     wrapRECdec0([RVB{var=fvar, exp=fnloop, resultty = NONE,
372 :     boundtvs=[], tyvars = ref []}], compInfo)
373 :     in markall
374 :     (LETexp(markdec ndec,
375 :     APPexp(markall(VARexp (ref nvar, [])), markend unitExp)))
376 :     end
377 :    
378 :     fun makeHANDLEexp(exp, rules, compInfo as {mkLvar=mkv, ...}: compInfo) =
379 :     let val v = newVALvar(exnID, mkv)
380 :     val r = RULE(VARpat v, RAISEexp(VARexp(ref(v),[]),UNDEFty))
381 :     val rules = completeMatch' r rules
382 :     in HANDLEexp(exp, HANDLER(FNexp(rules,UNDEFty)))
383 :     end
384 :    
385 :     fun isBoundConstructor(env,var) =
386 :     (case LU.lookValSym(env,var,fn _ => raise SE.Unbound)
387 :     of V.CON _ => true
388 :     | _ => false)
389 :     handle SE.Unbound => false
390 :    
391 :     fun checkBoundConstructor(env,var,err) =
392 :     if isBoundConstructor(env,var)
393 :     then err COMPLAIN ("rebinding data constructor \""
394 :     ^S.name var^ "\" as variable")
395 :     nullErrorBody
396 :     else ()
397 :    
398 :     (* transform a VarPat into either a variable or a constructor. If we are given
399 :     a long path (>1) then it has to be a constructor. *)
400 :    
401 :     fun pat_id (spath, env, err, compInfo as {mkLvar=mkv, ...}: compInfo) =
402 :     case spath
403 :     of SymPath.SPATH[id] =>
404 :     ((case LU.lookValSym (env,id,fn _ => raise SE.Unbound)
405 :     of V.CON c => CONpat(c,[])
406 :     | _ => VARpat(newVALvar(id,mkv)))
407 :     handle SE.Unbound => VARpat(newVALvar(id,mkv)))
408 :     | _ =>
409 :     CONpat((case LU.lookVal (env,spath,err)
410 :     of V.VAL c =>
411 :     (err COMPLAIN
412 :     ("variable found where constructor is required: "^
413 :     SymPath.toString spath)
414 :     nullErrorBody;
415 :     (bogusCON,[]))
416 :     | V.CON c => (c,[]))
417 :     handle SE.Unbound => bug "unbound untrapped")
418 :    
419 :     fun makeRECORDpat(l,flex,err) =
420 :     RECORDpat{fields=sortRecord(l,err), flex=flex, typ=ref UNDEFty}
421 :    
422 :     fun clean_pat err (CONpat(DATACON{const=false,name,...},_)) =
423 :     (err COMPLAIN ("data constructor "^S.name name^
424 :     " used without argument in pattern")
425 :     nullErrorBody;
426 :     WILDpat)
427 :     | clean_pat err p = p
428 :    
429 :     fun pat_to_string WILDpat = "_"
430 :     | pat_to_string (VARpat(VALvar{path,...})) = SP.toString path
431 :     | pat_to_string (CONpat(DATACON{name,...},_)) = S.name name
432 :     | pat_to_string (INTpat(i,_)) = IntInf.toString i
433 :     | pat_to_string (REALpat s) = s
434 :     | pat_to_string (STRINGpat s) = s
435 :     | pat_to_string (CHARpat s) = "#"^s
436 :     | pat_to_string (RECORDpat _) = "<record>"
437 :     | pat_to_string (APPpat _) = "<application>"
438 :     | pat_to_string (CONSTRAINTpat _) = "<constraint pattern>"
439 :     | pat_to_string (LAYEREDpat _) = "<layered pattern>"
440 :     | pat_to_string (VECTORpat _) = "<vector pattern>"
441 :     | pat_to_string (ORpat _) = "<or pattern>"
442 :     | pat_to_string _ = "<illegal pattern>"
443 :    
444 :     fun makeAPPpat err (CONpat(d as DATACON{const=false,...},t),p) = APPpat(d,t,p)
445 :     | makeAPPpat err (CONpat(d as DATACON{name,...},_),_) =
446 :     (err COMPLAIN
447 :     ("constant constructor applied to argument in pattern:"
448 :     ^ S.name name)
449 :     nullErrorBody;
450 :     WILDpat)
451 :     | makeAPPpat err (rator,_) =
452 :     (err COMPLAIN (concat["non-constructor applied to argument in pattern: ",
453 :     pat_to_string rator])
454 :     nullErrorBody;
455 :     WILDpat)
456 :    
457 :     fun makeLAYEREDpat ((x as VARpat _), y, _) = LAYEREDpat(x,y)
458 :     | makeLAYEREDpat (CONSTRAINTpat(x,t), y, err) =
459 :     makeLAYEREDpat(x,CONSTRAINTpat(y,t),err)
460 :     | makeLAYEREDpat (x,y,err) =
461 :     (err COMPLAIN "pattern to left of \"as\" must be variable" nullErrorBody;
462 :     y)
463 :    
464 :     fun calc_strictness (arity, body) =
465 :     let val argument_found = Array.array(arity,false)
466 :     fun search(VARty(ref(INSTANTIATED ty))) = search ty
467 :     | search(IBOUND n) = Array.update(argument_found,n,true)
468 :     | search(CONty(tycon, args)) = app search args
469 :     | search _ = () (* for now... *)
470 :     in search body;
471 :     ArrayExt.listofarray argument_found
472 :     end
473 :    
474 :    
475 :     (* checkBoundTyvars: check whether the tyvars appearing in a type (used) are
476 :     bound (as parameters in a type declaration) *)
477 :     fun checkBoundTyvars(used,bound,err) =
478 :     let val boundset =
479 :     foldr (fn (v,s) => TS.union(TS.singleton v,s,err))
480 :     TS.empty bound
481 :     fun nasty(ref(INSTANTIATED(VARty v))) = nasty v
482 :     | nasty(ubound as ref(UBOUND _)) =
483 :     err COMPLAIN ("unbound type variable in type declaration: " ^
484 :     (PPType.tyvarPrintname ubound))
485 :     nullErrorBody
486 :     | nasty _ = bug "checkBoundTyvars"
487 :     in app nasty (TS.elements(TS.diff(used, boundset, err)))
488 :     end
489 :    
490 :     (* labsym : Absyn.numberedLabel -> Symbol.symbol *)
491 :     fun labsym (LABEL{name, ...}) = name
492 :    
493 :     exception IsRec
494 :    
495 :     (** formerly defined in translate/nonrec.sml; now done during type checking *)
496 :     fun recDecs (rvbs as [RVB {var as V.VALvar{access=A.LVAR v, ...},
497 :     exp, resultty, tyvars, boundtvs}]) =
498 :     let fun findexp e =
499 :     (case e
500 :     of VARexp (ref(V.VALvar{access=A.LVAR x, ...}), _) =>
501 :     if v=x then raise IsRec else ()
502 :     | RECORDexp l => app (fn (lab, x)=>findexp x) l
503 :     | SEQexp l => app findexp l
504 :     | APPexp (a,b) => (findexp a; findexp b)
505 :     | CONSTRAINTexp (x,_) => findexp x
506 :     | HANDLEexp (x, HANDLER h) => (findexp x; findexp h)
507 :     | RAISEexp (x, _) => findexp x
508 :     | LETexp (d, x) => (finddec d; findexp x)
509 :     | CASEexp (x, l, _) =>
510 :     (findexp x; app (fn RULE (_, x) => findexp x) l)
511 :     | FNexp (l, _) => app (fn RULE (_, x) => findexp x) l
512 :     | MARKexp (x, _) => findexp x
513 :     | _ => ())
514 :    
515 :     and finddec d =
516 :     (case d
517 :     of VALdec vbl => app (fn (VB{exp,...}) => findexp exp) vbl
518 :     | VALRECdec rvbl => app (fn(RVB{exp,...})=>findexp exp) rvbl
519 :     | LOCALdec (a,b) => (finddec a; finddec b)
520 :     | SEQdec l => app finddec l
521 :     | ABSTYPEdec {body, ...} => finddec body
522 :     | MARKdec (dec,_) => finddec dec
523 :     | _ => ())
524 :    
525 :     in (findexp exp;
526 :     VALdec [VB{pat=VARpat var, tyvars=tyvars, boundtvs=boundtvs,
527 :     exp = case resultty
528 :     of SOME ty => CONSTRAINTexp(exp,ty)
529 :     | NONE => exp}])
530 :     handle IsRec => VALRECdec rvbs
531 :     end
532 :    
533 :     | recDecs rvbs = VALRECdec rvbs
534 :    
535 :    
536 :     (* hasModules tests whether there are explicit module declarations in a decl.
537 :     * This is used in elabMod when elaborating LOCALdec as a cheap
538 :     * approximate check of whether a declaration contains any functor
539 :     * declarations. *)
540 :     fun hasModules(StrDec _) = true
541 :     | hasModules(AbsDec _) = true
542 :     | hasModules(FctDec _) = true
543 :     | hasModules(LocalDec(dec_in,dec_out)) =
544 :     hasModules dec_in orelse hasModules dec_out
545 :     | hasModules(SeqDec decs) =
546 :     List.exists hasModules decs
547 :     | hasModules(MarkDec(dec,_)) = hasModules dec
548 :     | hasModules _ = false
549 :    
550 :    
551 :     end (* top-level local *)
552 :     end (* structure ElabUtil *)
553 :    
554 :    
555 :    
556 :     (*
557 :     * $Log: elabutil.sml,v $
558 :     * Revision 1.8 1997/11/11 05:24:17 dbm
559 :     * Cleanup error messages (initial lower case).
560 :     *
561 :     * Revision 1.7 1997/09/05 04:42:19 dbm
562 :     * Changes in TyvarSet signature; TyvarSet not opened (bug 1246).
563 :     *
564 :     * Revision 1.6 1997/08/25 19:20:32 riccardo
565 :     * Added support for tagging code objects with their source/bin file name.
566 :     *
567 :     * Revision 1.5 1997/04/18 15:41:10 george
568 :     * Fixing bug936 (uncaught exception ltUbound) -- zsh
569 :     *
570 :     * Revision 1.4 1997/04/02 04:02:31 dbm
571 :     * Minor change. Name of local variable tvref changed to tyvars.
572 :     *
573 :     * Revision 1.3 1997/03/22 18:17:03 dbm
574 :     * Added function hasModules, which is used in ElabMod to fix bug 905/952.
575 :     *
576 :     * Revision 1.2 1997/01/28 23:20:28 jhr
577 :     * Integer and word literals are now represented by IntInf.int (instead of
578 :     * as strings).
579 :     *
580 :     * Revision 1.1.1.1 1997/01/14 01:38:35 george
581 :     * Version 109.24
582 :     *
583 :     *)

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