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/cm/smlfile/skel-cvt.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/smlfile/skel-cvt.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 281 - (view) (download)

1 : blume 275 (*
2 :     * Convert ASTs to CM's trimmed version thereof.
3 :     *
4 :     * Copyright (c) 1995 by AT&T Bell Laboratories
5 :     * Copyright (c) 1993 by Carnegie Mellon University,
6 :     * School of Computer Science
7 :     * contact: Gene Rollins (rollins+@cs.cmu.edu)
8 :     *
9 :     * contact: Matthias Blume (blume@cs.princeton.edu)
10 :     *)
11 :     signature SKELCVT = sig
12 :     val convert : { tree: GenericVC.Ast.dec,
13 :     err: GenericVC.ErrorMsg.severity ->
14 :     GenericVC.Ast.region -> string -> unit }
15 : blume 281 -> { skeleton : Skeleton.decl, complain : unit -> unit }
16 : blume 275 end
17 :    
18 :     structure SkelCvt :> SKELCVT = struct
19 :    
20 :     open GenericVC.Ast Skeleton
21 :    
22 : blume 278 structure S = Symbol
23 : blume 275 structure SP = GenericVC.SymPath
24 :     structure SS = SymbolSet
25 :     structure EM = GenericVC.ErrorMsg
26 :    
27 :     val symbolModPath = SP.SPATH
28 :    
29 : blume 278 type symbol = Symbol.symbol
30 : blume 275 type path = symbol list
31 :    
32 :     fun allButLast lst =
33 :     case lst of
34 :     [] => []
35 :     | [last] => []
36 :     | head :: (tail as (_ :: _)) => head :: (allButLast tail)
37 :    
38 :     fun modRef (path, accum) =
39 :     case path of [] => accum
40 :     | [only] => accum
41 :     | head :: _ => SS.add (accum, head)
42 :    
43 :     fun declRef (path, accum) =
44 :     case path of
45 :     [] => accum
46 :     | head :: _ =>
47 :     (case accum of
48 :     [] => [DeclRef (SS.singleton head)]
49 :     | (DeclRef otherRefs) :: tail =>
50 :     (DeclRef (SS.add (otherRefs, head))) :: tail
51 :     | _ => (DeclRef (SS.singleton head)) :: accum)
52 :    
53 :     fun dropLast [x] = nil
54 :     | dropLast [] = []
55 :     | dropLast (a :: rest) = a :: (dropLast rest)
56 :    
57 :     fun modRefSet (modNames, accum) =
58 :     if SS.isEmpty modNames then accum
59 :     else
60 :     case accum of
61 :     [] => [DeclRef modNames]
62 :     | (DeclRef otherRefs) :: tail =>
63 :     (DeclRef (SS.union (modNames, otherRefs))) :: tail
64 :     | _ => (DeclRef modNames) :: accum
65 :    
66 :     fun localDec ((bind, body), accum) =
67 :     case (bind, body) of
68 :     ([], []) => accum
69 :     | ([], [DeclRef names]) => modRefSet (names, accum)
70 :     | ([DeclRef names], []) => modRefSet (names, accum)
71 :     | ([DeclRef names1], [DeclRef names2]) =>
72 :     modRefSet (SS.union (names1, names2), accum)
73 :     | args => (LocalDecl (SeqDecl bind, SeqDecl body)) :: accum
74 :    
75 :     fun c_dec ast =
76 :     case do_dec (ast, []) of
77 :     [] => DeclRef SS.empty
78 :     | [decl] => decl
79 :     | declList => SeqDecl declList
80 :    
81 :     and do_dec (ast, accum) =
82 :     case ast of
83 :     ValDec (arg, _) => foldr c_vb accum arg
84 :     | ValrecDec (arg, _) => foldr c_rvb accum arg
85 :     | FunDec (arg, _) => foldr c_fb accum arg
86 :     | TypeDec arg => modRefSet (foldr c_tb SS.empty arg, accum)
87 :     | DatatypeDec { datatycs, withtycs } =>
88 :     modRefSet (foldr c_db (foldr c_tb SS.empty withtycs) datatycs,
89 :     accum)
90 :     | AbstypeDec { abstycs, withtycs, body } =>
91 :     (* body is syntactically restricted to ldecs,
92 :     * no module scoping here *)
93 :     modRefSet (foldr c_db (foldr c_tb SS.empty withtycs) abstycs,
94 :     (c_dec body) :: accum)
95 :     | ExceptionDec arg =>
96 :     modRefSet (foldr c_eb SS.empty arg, accum)
97 :     | StrDec arg => (StrDecl (foldr c_strb [] arg)) :: accum
98 :     | AbsDec arg => (StrDecl (foldr c_strb [] arg)) :: accum
99 :     | FctDec arg => (FctDecl (foldr c_fctb [] arg)) :: accum
100 :     | SigDec arg => (StrDecl (foldr c_sigb [] arg)) :: accum
101 :     | FsigDec arg => (FctDecl (foldr c_fsigb [] arg)) :: accum
102 :     | LocalDec (bindingDec, bodyDec) =>
103 :     localDec ((do_dec (bindingDec, []),
104 :     do_dec (bodyDec, [])),
105 :     accum)
106 :     | SeqDec arg => foldr do_dec accum arg
107 :     | OpenDec arg =>
108 :     (OpenDecl (map (VarStrExp o symbolModPath) arg)) :: accum
109 :     | OvldDec arg => accum
110 :     | FixDec arg => accum
111 :     | MarkDec (arg, _) => do_dec (arg, accum)
112 :    
113 :     and c_strb (ast, accum) =
114 :     case ast of
115 :     Strb { name, def, constraint } =>
116 :     {
117 :     name = name,
118 :     def = c_strexp def,
119 :     constraint = sigexpConst constraint
120 :     } :: accum
121 :     | MarkStrb (arg, _) => c_strb (arg, accum)
122 :    
123 :     and c_fctb (ast, accum) =
124 :     case ast of
125 :     Fctb { name, def } =>
126 :     { name = name, def = c_fctexp def } :: accum
127 :     | MarkFctb (arg, _) => c_fctb (arg, accum)
128 :    
129 :     and c_sigb (ast, accum) =
130 :     case ast of
131 :     Sigb { name, def } =>
132 :     {
133 :     name = name,
134 :     def = c_sigexp def,
135 :     constraint = NONE
136 :     } :: accum
137 :     | MarkSigb (arg, _) => c_sigb (arg, accum)
138 :    
139 :     and c_fsigb (ast, accum) =
140 :     case ast of
141 :     Fsigb { name, def } =>
142 :     { name = name, def = c_fsigexp def } :: accum
143 :     | MarkFsigb (arg, _) => c_fsigb (arg, accum)
144 :    
145 :     and c_strexp ast =
146 :     case ast of
147 :     VarStr path => VarStrExp (symbolModPath path)
148 :     | BaseStr dec => BaseStrExp (c_dec dec)
149 :     | ConstrainedStr (strexp,NoSig) => c_strexp strexp
150 :     | ConstrainedStr (strexp, (Transparent sigexp | Opaque sigexp)) =>
151 :     ConStrExp (c_strexp strexp, c_sigexp sigexp)
152 :     | (AppStr (path, argList) |
153 :     AppStrI (path, argList)) =>
154 :     AppStrExp (symbolModPath path,
155 :     map (fn (se, _) => c_strexp se) argList)
156 :     | LetStr (bindings, body) =>
157 :     LetStrExp (c_dec bindings, c_strexp body)
158 :     | MarkStr (strexp, _) => c_strexp strexp
159 :    
160 :     and c_fctexp ast =
161 :     case ast of
162 :     VarFct (path, constraint) =>
163 :     VarFctExp (symbolModPath path, fsigexpConst constraint)
164 :     | BaseFct { params, body, constraint } =>
165 :     BaseFctExp {
166 : blume 279 params = SeqDecl (map functorParams params),
167 : blume 275 body = c_strexp body,
168 :     constraint = sigexpConst constraint
169 :     }
170 :     | AppFct (path, argList, constraint) =>
171 :     AppFctExp (symbolModPath path,
172 :     map (fn (se, _) => c_strexp se) argList,
173 :     fsigexpConst constraint)
174 :     | LetFct (bindings, body) =>
175 :     LetFctExp (c_dec bindings, c_fctexp body)
176 :     | MarkFct (arg, _) => c_fctexp arg
177 :    
178 :     and functorParams (symOpt, constraint) = let
179 :     val c = c_sigexp constraint
180 :     in
181 :     case symOpt of
182 : blume 279 NONE => OpenDecl [c]
183 :     | SOME sym => StrDecl [{ name = sym, def = c, constraint = NONE }]
184 : blume 275 end
185 :    
186 :     and sigexpConst sec =
187 :     case sec of
188 :     NoSig => NONE
189 :     | Transparent sigexp => SOME (c_sigexp sigexp)
190 :     | Opaque sigexp => SOME (c_sigexp sigexp)
191 :    
192 :     and c_sigexp ast =
193 :     case ast of
194 :     VarSig symbol => VarStrExp (symbolModPath [symbol])
195 :     | AugSig (se, whspecs) => let
196 :     fun f (WhType (_, _, ty), x) = c_ty (ty, x)
197 :     | f (WhStruct (_, head :: _), x) =
198 :     SS.add (x, head)
199 :     | f _ = raise Fail "decl/convert/c_sigexp"
200 :     in
201 : blume 279 LetStrExp (DeclRef (foldr f SS.empty whspecs),
202 :     c_sigexp se)
203 : blume 275 end
204 :     | BaseSig specList =>
205 :     BaseStrExp (SeqDecl (foldr c_spec [] specList))
206 :     | MarkSig (arg,_) => c_sigexp arg
207 :    
208 :     and fsigexpConst arg =
209 :     case arg of
210 :     NoSig => NONE
211 :     | Transparent fsigexp => SOME (c_fsigexp fsigexp)
212 :     | Opaque fsigexp => SOME (c_fsigexp fsigexp)
213 :    
214 :     and c_fsigexp ast =
215 :     case ast of
216 :     VarFsig symbol => VarFctExp (symbolModPath [symbol], NONE)
217 :     | BaseFsig { param, result } =>
218 :     BaseFctExp {
219 : blume 279 params = SeqDecl (map functorParams param),
220 : blume 275 body = c_sigexp result,
221 :     constraint = NONE
222 :     }
223 :     | MarkFsig (arg, _) => c_fsigexp arg
224 :    
225 :     and c_spec (ast, accum) =
226 :     case ast of
227 :     StrSpec arg => let
228 :     fun f (symbol, sigexp, NONE) =
229 :     {
230 :     name = symbol,
231 :     def = c_sigexp sigexp,
232 :     constraint = NONE
233 :     }
234 :     | f (symbol, sigexp, SOME path) =
235 :     {
236 :     name = symbol,
237 :     def = VarStrExp (symbolModPath path),
238 :     constraint = SOME(c_sigexp sigexp)
239 :     }
240 :     in
241 :     (StrDecl (map f arg)) :: accum
242 :     end
243 :     | TycSpec (arg, _) => let
244 :     fun filter ((_, _, SOME x) :: rest) = x :: filter rest
245 :     | filter (_ :: rest) = filter rest
246 :     | filter nil = nil
247 :     val mod'ref'set = foldr c_ty SS.empty (filter arg)
248 :     in
249 :     modRefSet (mod'ref'set, accum)
250 :     end
251 :     | FctSpec arg => let
252 :     fun f (symbol, fsigexp) =
253 :     { name = symbol, def = c_fsigexp fsigexp }
254 :     in
255 :     (FctDecl (map f arg)) :: accum
256 :     end
257 :     | ValSpec arg => let
258 :     val mod'ref'set = foldr c_ty SS.empty (map #2 arg)
259 :     in
260 :     modRefSet (mod'ref'set, accum)
261 :     end
262 :     | DataSpec { datatycs, withtycs } =>
263 :     modRefSet (foldr c_db (foldr c_tb SS.empty withtycs) datatycs,
264 :     accum)
265 :     | ExceSpec arg => let
266 :     val mod'ref'set = foldr tyoption SS.empty (map #2 arg)
267 :     in
268 :     modRefSet (mod'ref'set, accum)
269 :     end
270 :     | ShareStrSpec arg => foldr declRef accum arg
271 :     | ShareTycSpec arg => foldr declRef accum (map dropLast arg)
272 :     | IncludeSpec sigexp => (OpenDecl [c_sigexp sigexp]) :: accum
273 :     | MarkSpec (arg, _) => c_spec (arg, accum)
274 :    
275 :     and c_vb (ast, accum) =
276 :     case ast of
277 :     Vb { pat, exp, lazyp } =>
278 :     modRefSet (c_pat (pat, SS.empty), c_exp (exp, accum))
279 :     | MarkVb (arg, _) => c_vb (arg, accum)
280 :    
281 :     and c_rvb (ast, accum) =
282 :     case ast of
283 :     Rvb { var, exp, resultty,... } =>
284 :     modRefSet (tyoption (resultty, SS.empty), c_exp (exp, accum))
285 :     | MarkRvb (arg, _) => c_rvb (arg, accum)
286 :    
287 :     and c_fb (ast, accum) =
288 :     case ast of
289 :     Fb (clauses, _) => foldr c_clause accum clauses
290 :     | MarkFb (arg,_) => c_fb (arg, accum)
291 :    
292 :     and c_clause (Clause { pats, resultty, exp }, accum) =
293 :     modRefSet
294 :     (foldr c_pat (tyoption (resultty, SS.empty)) (map #item pats),
295 :     c_exp (exp, accum))
296 :    
297 :     and c_tb (ast, accum) =
298 :     case ast of
299 :     Tb { tyc, def, tyvars } => c_ty (def, accum)
300 :     | MarkTb (arg, _) => c_tb (arg, accum)
301 :    
302 :     and c_db (ast, accum) =
303 :     case ast of
304 :     Db { tyc, tyvars, rhs, lazyp } => c_dbrhs (rhs, accum)
305 :     | MarkDb (arg, _) => c_db (arg, accum)
306 :    
307 :     and c_dbrhs (ast,accum) =
308 :     case ast of
309 :     Constrs def => foldr tyoption accum (map #2 def)
310 :     | Repl consName => modRef (consName, accum)
311 :    
312 :     and c_eb (ast, accum) =
313 :     case ast of
314 :     EbGen { exn, etype } => tyoption (etype, accum)
315 :     | EbDef { exn, edef } => modRef (edef, accum)
316 :     | MarkEb (arg, _) => c_eb (arg, accum)
317 :    
318 :     and c_exp (ast, accum) =
319 :     case ast of
320 :     VarExp path =>
321 :     (case path of
322 :     [] => accum
323 :     | [only] => accum
324 :     | head :: _ =>
325 :     (case accum of
326 :     [] => [DeclRef (SS.singleton head)]
327 :     | (DeclRef otherRefs) :: tail =>
328 :     (DeclRef (SS.add (otherRefs, head))) :: tail
329 :     | _ => (DeclRef (SS.singleton head)) :: accum))
330 :     | FnExp arg => foldr c_rule accum arg
331 :     | FlatAppExp items => foldr c_exp accum (map #item items)
332 :     | AppExp { function, argument } =>
333 :     c_exp (function, c_exp (argument, accum))
334 :     | CaseExp {expr, rules } =>
335 :     c_exp (expr, foldr c_rule accum rules)
336 :     | LetExp { dec, expr } =>
337 :     (* syntactically only ldecs; no module scoping here *)
338 :     localDec ((do_dec (dec, []), c_exp (expr, [])), accum)
339 :     | SeqExp arg => foldr c_exp accum arg
340 :     | RecordExp arg => foldr c_exp accum (map #2 arg)
341 :     | ListExp arg => foldr c_exp accum arg
342 :     | TupleExp arg => foldr c_exp accum arg
343 :     | SelectorExp symbol => accum
344 :     | ConstraintExp { expr, constraint } =>
345 :     c_exp (expr, modRefSet (c_ty (constraint, SS.empty), accum))
346 :     | HandleExp { expr, rules } =>
347 :     c_exp (expr, foldr c_rule accum rules)
348 :     | RaiseExp expr => c_exp (expr, accum)
349 :     | IfExp { test, thenCase, elseCase } =>
350 :     c_exp (test, c_exp (thenCase, c_exp (elseCase, accum)))
351 :     | AndalsoExp (expr1, expr2) => c_exp (expr1, c_exp (expr2, accum))
352 :     | OrelseExp (expr1, expr2) => c_exp (expr1, c_exp (expr2, accum))
353 :     | WhileExp { test, expr } => c_exp (test, c_exp (expr, accum))
354 :     | MarkExp (arg, _) => c_exp (arg, accum)
355 :     | VectorExp arg => foldr c_exp accum arg
356 :     | _ => accum
357 :    
358 :     and c_rule (Rule { pat, exp }, accum) =
359 :     modRefSet (c_pat (pat, SS.empty), c_exp (exp, accum))
360 :    
361 :     and c_pat (ast, accum) =
362 :     case ast of
363 :     VarPat path => modRef (path, accum)
364 :     | RecordPat { def, ... } => foldr c_pat accum (map #2 def)
365 :     | ListPat arg => foldr c_pat accum arg
366 :     | TuplePat arg => foldr c_pat accum arg
367 :     | FlatAppPat items => foldr c_pat accum (map #item items)
368 :     | AppPat { constr, argument } =>
369 :     c_pat (constr, c_pat (argument, accum))
370 :     | ConstraintPat { pattern, constraint } =>
371 :     c_pat (pattern, c_ty (constraint, accum))
372 :     | LayeredPat { varPat, expPat } =>
373 :     c_pat (varPat, c_pat (expPat, accum))
374 :     | VectorPat arg => foldr c_pat accum arg
375 :     | OrPat arg => foldr c_pat accum arg
376 :     | MarkPat (arg, _) => c_pat (arg, accum)
377 :     | _ => accum
378 :    
379 :     and c_ty (ast, accum) =
380 :     case ast of
381 :     VarTy arg => accum
382 :     | ConTy (consName, args) =>
383 :     modRef (consName, foldr c_ty accum args)
384 :     | RecordTy arg => foldr c_ty accum (map #2 arg)
385 :     | TupleTy arg => foldr c_ty accum arg
386 :     | MarkTy (arg, _) => c_ty (arg, accum)
387 :    
388 :     and tyoption (arg, accum) =
389 :     case arg of
390 :     NONE => accum
391 :     | SOME ty => c_ty (ty, accum)
392 :    
393 : blume 281 fun convert { tree, err } = let
394 :     (* build a function that will complain (once you call it)
395 :     * about any existing restriction violations *)
396 :     fun newReg reg = let
397 :     fun sameReg (LocalDec (_, body), k) = sameReg (body, k)
398 :     | sameReg (SeqDec l, k) = foldl sameReg k l
399 :     | sameReg (OpenDec _, k) =
400 :     (fn () => (k (); err EM.COMPLAIN reg "toplevel open"))
401 :     | sameReg (MarkDec (arg, reg), k) = newReg reg (arg, k)
402 :     | sameReg ((StrDec _ | AbsDec _ | FctDec _ | SigDec _ |
403 :     FsigDec _), k) = k
404 :     | sameReg (_, k) =
405 :     (fn () =>
406 :     (k (); err EM.WARN reg "definition not tracked by CM"))
407 :    
408 :     in
409 :     sameReg
410 :     end
411 : blume 275 in
412 : blume 281 { complain = newReg (0, 0) (tree, fn () => ()), skeleton = c_dec tree }
413 : blume 275 end
414 :     end

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