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 278 - (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 :     -> Skeleton.decl
16 :     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 :     params = map functorParams params,
167 :     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 :     NONE => (NONE,c)
183 :     | SOME sym => (SOME sym, c)
184 :     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 :     AugStrExp (c_sigexp se, foldr f SS.empty whspecs)
202 :     end
203 :     | BaseSig specList =>
204 :     BaseStrExp (SeqDecl (foldr c_spec [] specList))
205 :     | MarkSig (arg,_) => c_sigexp arg
206 :    
207 :     and fsigexpConst arg =
208 :     case arg of
209 :     NoSig => NONE
210 :     | Transparent fsigexp => SOME (c_fsigexp fsigexp)
211 :     | Opaque fsigexp => SOME (c_fsigexp fsigexp)
212 :    
213 :     and c_fsigexp ast =
214 :     case ast of
215 :     VarFsig symbol => VarFctExp (symbolModPath [symbol], NONE)
216 :     | BaseFsig { param, result } =>
217 :     BaseFctExp {
218 :     params = map functorParams param,
219 :     body = c_sigexp result,
220 :     constraint = NONE
221 :     }
222 :     | MarkFsig (arg, _) => c_fsigexp arg
223 :    
224 :     and c_spec (ast, accum) =
225 :     case ast of
226 :     StrSpec arg => let
227 :     fun f (symbol, sigexp, NONE) =
228 :     {
229 :     name = symbol,
230 :     def = c_sigexp sigexp,
231 :     constraint = NONE
232 :     }
233 :     | f (symbol, sigexp, SOME path) =
234 :     {
235 :     name = symbol,
236 :     def = VarStrExp (symbolModPath path),
237 :     constraint = SOME(c_sigexp sigexp)
238 :     }
239 :     in
240 :     (StrDecl (map f arg)) :: accum
241 :     end
242 :     | TycSpec (arg, _) => let
243 :     fun filter ((_, _, SOME x) :: rest) = x :: filter rest
244 :     | filter (_ :: rest) = filter rest
245 :     | filter nil = nil
246 :     val mod'ref'set = foldr c_ty SS.empty (filter arg)
247 :     in
248 :     modRefSet (mod'ref'set, accum)
249 :     end
250 :     | FctSpec arg => let
251 :     fun f (symbol, fsigexp) =
252 :     { name = symbol, def = c_fsigexp fsigexp }
253 :     in
254 :     (FctDecl (map f arg)) :: accum
255 :     end
256 :     | ValSpec arg => let
257 :     val mod'ref'set = foldr c_ty SS.empty (map #2 arg)
258 :     in
259 :     modRefSet (mod'ref'set, accum)
260 :     end
261 :     | DataSpec { datatycs, withtycs } =>
262 :     modRefSet (foldr c_db (foldr c_tb SS.empty withtycs) datatycs,
263 :     accum)
264 :     | ExceSpec arg => let
265 :     val mod'ref'set = foldr tyoption SS.empty (map #2 arg)
266 :     in
267 :     modRefSet (mod'ref'set, accum)
268 :     end
269 :     | ShareStrSpec arg => foldr declRef accum arg
270 :     | ShareTycSpec arg => foldr declRef accum (map dropLast arg)
271 :     | IncludeSpec sigexp => (OpenDecl [c_sigexp sigexp]) :: accum
272 :     | MarkSpec (arg, _) => c_spec (arg, accum)
273 :    
274 :     and c_vb (ast, accum) =
275 :     case ast of
276 :     Vb { pat, exp, lazyp } =>
277 :     modRefSet (c_pat (pat, SS.empty), c_exp (exp, accum))
278 :     | MarkVb (arg, _) => c_vb (arg, accum)
279 :    
280 :     and c_rvb (ast, accum) =
281 :     case ast of
282 :     Rvb { var, exp, resultty,... } =>
283 :     modRefSet (tyoption (resultty, SS.empty), c_exp (exp, accum))
284 :     | MarkRvb (arg, _) => c_rvb (arg, accum)
285 :    
286 :     and c_fb (ast, accum) =
287 :     case ast of
288 :     Fb (clauses, _) => foldr c_clause accum clauses
289 :     | MarkFb (arg,_) => c_fb (arg, accum)
290 :    
291 :     and c_clause (Clause { pats, resultty, exp }, accum) =
292 :     modRefSet
293 :     (foldr c_pat (tyoption (resultty, SS.empty)) (map #item pats),
294 :     c_exp (exp, accum))
295 :    
296 :     and c_tb (ast, accum) =
297 :     case ast of
298 :     Tb { tyc, def, tyvars } => c_ty (def, accum)
299 :     | MarkTb (arg, _) => c_tb (arg, accum)
300 :    
301 :     and c_db (ast, accum) =
302 :     case ast of
303 :     Db { tyc, tyvars, rhs, lazyp } => c_dbrhs (rhs, accum)
304 :     | MarkDb (arg, _) => c_db (arg, accum)
305 :    
306 :     and c_dbrhs (ast,accum) =
307 :     case ast of
308 :     Constrs def => foldr tyoption accum (map #2 def)
309 :     | Repl consName => modRef (consName, accum)
310 :    
311 :     and c_eb (ast, accum) =
312 :     case ast of
313 :     EbGen { exn, etype } => tyoption (etype, accum)
314 :     | EbDef { exn, edef } => modRef (edef, accum)
315 :     | MarkEb (arg, _) => c_eb (arg, accum)
316 :    
317 :     and c_exp (ast, accum) =
318 :     case ast of
319 :     VarExp path =>
320 :     (case path of
321 :     [] => accum
322 :     | [only] => accum
323 :     | head :: _ =>
324 :     (case accum of
325 :     [] => [DeclRef (SS.singleton head)]
326 :     | (DeclRef otherRefs) :: tail =>
327 :     (DeclRef (SS.add (otherRefs, head))) :: tail
328 :     | _ => (DeclRef (SS.singleton head)) :: accum))
329 :     | FnExp arg => foldr c_rule accum arg
330 :     | FlatAppExp items => foldr c_exp accum (map #item items)
331 :     | AppExp { function, argument } =>
332 :     c_exp (function, c_exp (argument, accum))
333 :     | CaseExp {expr, rules } =>
334 :     c_exp (expr, foldr c_rule accum rules)
335 :     | LetExp { dec, expr } =>
336 :     (* syntactically only ldecs; no module scoping here *)
337 :     localDec ((do_dec (dec, []), c_exp (expr, [])), accum)
338 :     | SeqExp arg => foldr c_exp accum arg
339 :     | RecordExp arg => foldr c_exp accum (map #2 arg)
340 :     | ListExp arg => foldr c_exp accum arg
341 :     | TupleExp arg => foldr c_exp accum arg
342 :     | SelectorExp symbol => accum
343 :     | ConstraintExp { expr, constraint } =>
344 :     c_exp (expr, modRefSet (c_ty (constraint, SS.empty), accum))
345 :     | HandleExp { expr, rules } =>
346 :     c_exp (expr, foldr c_rule accum rules)
347 :     | RaiseExp expr => c_exp (expr, accum)
348 :     | IfExp { test, thenCase, elseCase } =>
349 :     c_exp (test, c_exp (thenCase, c_exp (elseCase, accum)))
350 :     | AndalsoExp (expr1, expr2) => c_exp (expr1, c_exp (expr2, accum))
351 :     | OrelseExp (expr1, expr2) => c_exp (expr1, c_exp (expr2, accum))
352 :     | WhileExp { test, expr } => c_exp (test, c_exp (expr, accum))
353 :     | MarkExp (arg, _) => c_exp (arg, accum)
354 :     | VectorExp arg => foldr c_exp accum arg
355 :     | _ => accum
356 :    
357 :     and c_rule (Rule { pat, exp }, accum) =
358 :     modRefSet (c_pat (pat, SS.empty), c_exp (exp, accum))
359 :    
360 :     and c_pat (ast, accum) =
361 :     case ast of
362 :     VarPat path => modRef (path, accum)
363 :     | RecordPat { def, ... } => foldr c_pat accum (map #2 def)
364 :     | ListPat arg => foldr c_pat accum arg
365 :     | TuplePat arg => foldr c_pat accum arg
366 :     | FlatAppPat items => foldr c_pat accum (map #item items)
367 :     | AppPat { constr, argument } =>
368 :     c_pat (constr, c_pat (argument, accum))
369 :     | ConstraintPat { pattern, constraint } =>
370 :     c_pat (pattern, c_ty (constraint, accum))
371 :     | LayeredPat { varPat, expPat } =>
372 :     c_pat (varPat, c_pat (expPat, accum))
373 :     | VectorPat arg => foldr c_pat accum arg
374 :     | OrPat arg => foldr c_pat accum arg
375 :     | MarkPat (arg, _) => c_pat (arg, accum)
376 :     | _ => accum
377 :    
378 :     and c_ty (ast, accum) =
379 :     case ast of
380 :     VarTy arg => accum
381 :     | ConTy (consName, args) =>
382 :     modRef (consName, foldr c_ty accum args)
383 :     | RecordTy arg => foldr c_ty accum (map #2 arg)
384 :     | TupleTy arg => foldr c_ty accum arg
385 :     | MarkTy (arg, _) => c_ty (arg, accum)
386 :    
387 :     and tyoption (arg, accum) =
388 :     case arg of
389 :     NONE => accum
390 :     | SOME ty => c_ty (ty, accum)
391 :    
392 :     fun check_toplevel (ast, err) = let
393 :     fun check_topl (StrDec _, _) = ()
394 :     | check_topl (AbsDec _, _) = ()
395 :     | check_topl (FctDec _, _) = ()
396 :     | check_topl (SigDec _, _) = ()
397 :     | check_topl (FsigDec _, _) = ()
398 :     | check_topl (LocalDec (_, body), reg) = check_topl (body, reg)
399 :     | check_topl (SeqDec arg, reg) =
400 :     app (fn ast => check_topl (ast, reg)) arg
401 :     | check_topl (OpenDec _, reg) = err EM.COMPLAIN reg "toplevel open"
402 :     | check_topl (MarkDec (arg, reg), _) = check_topl (arg, reg)
403 :     | check_topl (_, reg) =
404 :     err EM.WARN reg "definition not tracked by CM"
405 :     in
406 :     check_topl (ast, (0, 0))
407 :     end
408 :    
409 :     fun convert { tree, err } = (check_toplevel (tree, err); c_dec tree)
410 :    
411 :     end

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