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 286 - (view) (download)

1 : blume 275 (*
2 :     * Convert ASTs to CM's trimmed version thereof.
3 :     *
4 : blume 286 * Copyright (c) 1999 by Lucent Technologies, Bell Laboratories
5 : blume 275 * Copyright (c) 1995 by AT&T Bell Laboratories
6 :     * Copyright (c) 1993 by Carnegie Mellon University,
7 :     * School of Computer Science
8 :     * contact: Gene Rollins (rollins+@cs.cmu.edu)
9 :     *
10 :     * contact: Matthias Blume (blume@cs.princeton.edu)
11 :     *)
12 :     signature SKELCVT = sig
13 :     val convert : { tree: GenericVC.Ast.dec,
14 :     err: GenericVC.ErrorMsg.severity ->
15 :     GenericVC.Ast.region -> string -> unit }
16 : blume 281 -> { skeleton : Skeleton.decl, complain : unit -> unit }
17 : blume 275 end
18 :    
19 :     structure SkelCvt :> SKELCVT = struct
20 :    
21 :     open GenericVC.Ast Skeleton
22 :    
23 : blume 278 structure S = Symbol
24 : blume 275 structure SP = GenericVC.SymPath
25 :     structure SS = SymbolSet
26 :     structure EM = GenericVC.ErrorMsg
27 :    
28 : blume 278 type symbol = Symbol.symbol
29 : blume 275 type path = symbol list
30 :    
31 : blume 286 infix o'
32 :     fun (f o' g) (x, y) = f (g x, y)
33 : blume 275
34 : blume 286 (* given a path, add an element to a set of module references *)
35 :     fun s_addP ([], a) = a (* can this happen at all? *)
36 :     | s_addP ([only], a) = a (* no module name here *)
37 :     | s_addP (head :: _, a) = SS.add (a, head)
38 : blume 275
39 : blume 286 (* given a path, add an element to a decl list *)
40 :     fun d_addP ([], a) = a
41 :     | d_addP (h :: _, []) = [Ref (SS.singleton h)]
42 :     | d_addP (h :: _, Ref s :: a) = Ref (SS.add (s, h)) :: a
43 :     | d_addP (h :: _, a) = Ref (SS.singleton h) :: a
44 : blume 275
45 : blume 286 (* given a set of module references, add it to a decl list *)
46 :     fun d_addS (s, a) =
47 :     if SS.isEmpty s then a
48 :     else case a of
49 :     [] => [Ref s]
50 :     | Ref s' :: a => Ref (SS.union (s, s')) :: a
51 :     | a => Ref s :: a
52 : blume 275
53 : blume 286 fun localDec ([], [], a) = a
54 :     | localDec ([], [Ref s], a) = d_addS (s, a)
55 :     | localDec (Ref s :: t, body, a) = d_addS (s, localDec (t, body, a))
56 :     | localDec (bdg, body, a) = Local (Seq bdg, Seq body) :: a
57 : blume 275
58 : blume 286 fun con (s1, NONE) = s1
59 :     | con (s1, SOME s2) = Con (s1, s2)
60 : blume 275
61 : blume 286 fun c_dec ast = Seq (do_dec (ast, []))
62 : blume 275
63 : blume 286 and do_dec (ValDec (l, _), a) = foldr c_vb a l
64 :     | do_dec (ValrecDec (l, _), a) = foldr c_rvb a l
65 :     | do_dec (FunDec (l, _), a) = foldr c_fb a l
66 :     | do_dec (TypeDec l, a) = d_addS (foldl c_tb SS.empty l, a)
67 :     | do_dec (DatatypeDec { datatycs, withtycs }, a) =
68 :     d_addS (foldl c_db (foldl c_tb SS.empty withtycs) datatycs, a)
69 :     | do_dec (AbstypeDec { abstycs, withtycs, body }, a) =
70 :     (* body is syntactically restricted to ldecs,
71 :     * no module scoping here *)
72 :     d_addS (foldl c_db (foldl c_tb SS.empty withtycs) abstycs,
73 :     c_dec body :: a)
74 :     | do_dec (ExceptionDec l, a) = d_addS (foldl c_eb SS.empty l, a)
75 :     | do_dec ((StrDec l | AbsDec l), a) = Par (foldr c_strb [] l) :: a
76 :     | do_dec (FctDec l, a) = Par (foldr c_fctb [] l) :: a
77 :     | do_dec (SigDec l, a) = Par (foldr c_sigb [] l) :: a
78 :     | do_dec (FsigDec l, a) = Par (foldr c_fsigb [] l) :: a
79 :     | do_dec (LocalDec (bdg, body), a) =
80 :     localDec (do_dec (bdg, []), do_dec (body, []), a)
81 :     | do_dec (SeqDec l, a) = foldr do_dec a l
82 :     | do_dec (OpenDec l, a) = Par (map (Open o Var o SP.SPATH) l) :: a
83 :     | do_dec ((OvldDec _ | FixDec _), a) = a
84 :     | do_dec (MarkDec (arg, _), a) = do_dec (arg, a)
85 : blume 275
86 : blume 286 and c_strb (Strb { name, def, constraint }, a) =
87 :     Bind (name, con (c_strexp def, sigexpConst constraint)) :: a
88 :     | c_strb (MarkStrb (arg, _), a) = c_strb (arg, a)
89 : blume 275
90 : blume 286 and c_fctb (Fctb { name, def }, a) = Bind (name, c_fctexp def) :: a
91 :     | c_fctb (MarkFctb (arg, _), a) = c_fctb (arg, a)
92 : blume 275
93 : blume 286 and c_sigb (Sigb { name, def }, a) = Bind (name, c_sigexp def) :: a
94 :     | c_sigb (MarkSigb (arg, _), a) = c_sigb (arg, a)
95 : blume 275
96 : blume 286 and c_fsigb (Fsigb { name, def }, a) = Bind (name, c_fsigexp def) :: a
97 :     | c_fsigb (MarkFsigb (arg, _), a) = c_fsigb (arg, a)
98 : blume 275
99 : blume 286 and c_strexp (VarStr path) = Var (SP.SPATH path)
100 :     | c_strexp (BaseStr dec) = Decl (c_dec dec)
101 :     | c_strexp (ConstrainedStr (s, NoSig)) = c_strexp s
102 :     | c_strexp (ConstrainedStr (s, (Transparent g | Opaque g))) =
103 :     Con (c_strexp s, c_sigexp g)
104 :     | c_strexp (AppStr (p, l) | AppStrI (p, l)) =
105 :     App (SP.SPATH p, map (c_strexp o #1) l)
106 :     | c_strexp (LetStr (bdg, body)) = Let (c_dec bdg, c_strexp body)
107 :     | c_strexp (MarkStr (s, _)) = c_strexp s
108 : blume 275
109 : blume 286 and c_fctexp (VarFct (p, c)) = con (Var (SP.SPATH p), fsigexpConst c)
110 :     | c_fctexp (BaseFct { params = p, body = b, constraint = c }) =
111 :     Let (Seq (map functorParams p), con (c_strexp b, sigexpConst c))
112 :     | c_fctexp (AppFct (p, l, c)) =
113 :     con (App (SP.SPATH p, map (c_strexp o #1) l), fsigexpConst c)
114 :     | c_fctexp (LetFct (bdg, body)) = Let (c_dec bdg, c_fctexp body)
115 :     | c_fctexp (MarkFct (arg, _)) = c_fctexp arg
116 : blume 275
117 : blume 286 and functorParams (NONE, c) = Open (c_sigexp c)
118 :     | functorParams (SOME s, c) = Bind (s, c_sigexp c)
119 : blume 275
120 : blume 286 and sigexpConst NoSig = NONE
121 :     | sigexpConst (Transparent g | Opaque g) = SOME (c_sigexp g)
122 : blume 275
123 : blume 286 and c_sigexp (VarSig s) = Var (SP.SPATH [s])
124 :     | c_sigexp (AugSig (g, whspecs)) = let
125 :     fun f (WhType (_, _, ty), x) = c_ty (ty, x)
126 :     | f (WhStruct (_, head :: _), x) = SS.add (x, head)
127 :     | f _ = raise Fail "skel-cvt/c_sigexp"
128 :     in
129 :     Let (Ref (foldl f SS.empty whspecs), c_sigexp g)
130 :     end
131 :     | c_sigexp (BaseSig l) = Decl (Seq (foldr c_spec [] l))
132 :     | c_sigexp (MarkSig (arg, _)) = c_sigexp arg
133 : blume 275
134 : blume 286 and fsigexpConst NoSig = NONE
135 :     | fsigexpConst (Transparent fg | Opaque fg) = SOME (c_fsigexp fg)
136 : blume 275
137 : blume 286 and c_fsigexp (VarFsig s) = Var (SP.SPATH [s])
138 :     | c_fsigexp (BaseFsig { param, result }) =
139 :     Let (Seq (map functorParams param), c_sigexp result)
140 :     | c_fsigexp (MarkFsig (arg, _)) = c_fsigexp arg
141 : blume 275
142 : blume 286 and c_spec (StrSpec l, a) = let
143 :     fun f (s, g, c) =
144 :     Bind (s, con (c_sigexp g, Option.map (Var o SP.SPATH) c))
145 :     in
146 :     (Par (map f l)) :: a
147 :     end
148 :     | c_spec (TycSpec (l, _), a) = let
149 :     fun f ((_, _, SOME t), s) = c_ty (t, s)
150 :     | f (_, s) = s
151 :     in
152 :     d_addS (foldl f SS.empty l, a)
153 :     end
154 :     | c_spec (FctSpec l, a) =
155 :     Par (map (fn (s, g) => Bind (s, c_fsigexp g)) l) :: a
156 :     | c_spec (ValSpec l, a) = d_addS (foldl (c_ty o' #2) SS.empty l, a)
157 :     | c_spec (DataSpec { datatycs, withtycs }, a) =
158 :     d_addS (foldl c_db (foldl c_tb SS.empty withtycs) datatycs, a)
159 :     | c_spec (ExceSpec l, a) = d_addS (foldl (tyoption o' #2) SS.empty l, a)
160 :     | c_spec (ShareStrSpec l, a) = foldl d_addP a l
161 :     | c_spec (ShareTycSpec l, a) = d_addS (foldl s_addP SS.empty l, a)
162 :     | c_spec (IncludeSpec g, a) = Open (c_sigexp g) :: a
163 :     | c_spec (MarkSpec (arg, _), a) = c_spec (arg, a)
164 : blume 275
165 : blume 286 and c_vb (Vb { pat, exp, lazyp }, a) =
166 :     d_addS (c_pat (pat, SS.empty), c_exp (exp, a))
167 :     | c_vb (MarkVb (arg, _), a) = c_vb (arg, a)
168 : blume 275
169 : blume 286 and c_rvb (Rvb { var, exp, resultty, ... }, a) =
170 :     d_addS (tyoption (resultty, SS.empty), c_exp (exp, a))
171 :     | c_rvb (MarkRvb (arg, _), a) = c_rvb (arg, a)
172 : blume 275
173 : blume 286 and c_fb (Fb (l, _), a) = foldr c_clause a l
174 :     | c_fb (MarkFb (arg, _), a) = c_fb (arg, a)
175 : blume 275
176 : blume 286 and c_clause (Clause { pats = p, resultty = t, exp = e }, a) =
177 :     d_addS (foldl (c_pat o' #item) (tyoption (t, SS.empty)) p,
178 :     c_exp (e, a))
179 : blume 275
180 : blume 286 and c_tb (Tb { tyc, def, tyvars }, a) = c_ty (def, a)
181 :     | c_tb (MarkTb (arg, _), a) = c_tb (arg, a)
182 : blume 275
183 : blume 286 and c_db (Db { tyc, tyvars, rhs, lazyp }, a) = c_dbrhs (rhs, a)
184 :     | c_db (MarkDb (arg, _), a) = c_db (arg, a)
185 : blume 275
186 : blume 286 and c_dbrhs (Constrs def, a) = foldl (tyoption o' #2) a def
187 :     | c_dbrhs (Repl cn, a) = s_addP (cn, a)
188 : blume 275
189 : blume 286 and c_eb (EbGen { exn, etype }, a) = tyoption (etype, a)
190 :     | c_eb (EbDef { exn, edef }, a) = s_addP (edef, a)
191 :     | c_eb (MarkEb (arg, _), a) = c_eb (arg, a)
192 : blume 275
193 : blume 286 and c_exp (VarExp p, a) = d_addP (p, a)
194 :     | c_exp (FnExp arg, a) = foldr c_rule a arg
195 :     | c_exp (FlatAppExp l, a) = foldr (c_exp o' #item) a l
196 :     | c_exp (AppExp { function, argument }, a) =
197 :     c_exp (function, c_exp (argument, a))
198 :     | c_exp (CaseExp { expr, rules }, a) = c_exp (expr, foldr c_rule a rules)
199 :     | c_exp (LetExp { dec, expr }, a) =
200 :     localDec (do_dec (dec, []), c_exp (expr, []), a)
201 :     | c_exp ((SeqExp l | ListExp l | TupleExp l | VectorExp l), a) =
202 :     foldr c_exp a l
203 :     | c_exp (RecordExp l, a) = foldr (c_exp o' #2) a l
204 :     | c_exp (SelectorExp _, a) = a
205 :     | c_exp (ConstraintExp { expr, constraint }, a) =
206 :     c_exp (expr, d_addS (c_ty (constraint, SS.empty), a))
207 :     | c_exp (HandleExp { expr, rules }, a) =
208 :     c_exp (expr, foldr c_rule a rules)
209 :     | c_exp (RaiseExp e, a) = c_exp (e, a)
210 :     | c_exp (IfExp { test, thenCase, elseCase }, a) =
211 :     c_exp (test, c_exp (thenCase, c_exp (elseCase, a)))
212 :     | c_exp ((AndalsoExp (e1, e2) | OrelseExp (e1, e2)), a) =
213 :     c_exp (e1, c_exp (e2, a))
214 :     | c_exp (WhileExp { test, expr }, a) = c_exp (test, c_exp (expr, a))
215 :     | c_exp (MarkExp (arg, _), a) = c_exp (arg, a)
216 :     | c_exp ((IntExp _|WordExp _|RealExp _|StringExp _|CharExp _), a) = a
217 : blume 275
218 : blume 286 and c_rule (Rule { pat, exp }, a) =
219 :     d_addS (c_pat (pat, SS.empty), c_exp (exp, a))
220 : blume 275
221 : blume 286 and c_pat (VarPat p, a) = s_addP (p, a)
222 :     | c_pat (RecordPat { def, ... }, a) = foldl (c_pat o' #2) a def
223 :     | c_pat ((ListPat l | TuplePat l | VectorPat l | OrPat l), a) =
224 :     foldl c_pat a l
225 :     | c_pat (FlatAppPat l, a) = foldl (c_pat o' #item) a l
226 :     | c_pat (AppPat { constr, argument }, a) =
227 :     c_pat (constr, c_pat (argument, a))
228 :     | c_pat (ConstraintPat { pattern, constraint }, a) =
229 :     c_pat (pattern, c_ty (constraint, a))
230 :     | c_pat (LayeredPat { varPat, expPat }, a) =
231 :     c_pat (varPat, c_pat (expPat, a))
232 :     | c_pat (MarkPat (arg, _), a) = c_pat (arg, a)
233 :     | c_pat ((WildPat|IntPat _|WordPat _|StringPat _|CharPat _), a) = a
234 : blume 275
235 : blume 286 and c_ty (VarTy _, a) = a
236 :     | c_ty (ConTy (cn, l), a) = s_addP (cn, foldl c_ty a l)
237 :     | c_ty (RecordTy l, a) = foldl (c_ty o' #2) a l
238 :     | c_ty (TupleTy l, a) = foldl c_ty a l
239 :     | c_ty (MarkTy (arg, _), a) = c_ty (arg, a)
240 : blume 275
241 : blume 286 and tyoption (NONE, a) = a
242 :     | tyoption (SOME ty, a) = c_ty (ty, a)
243 : blume 275
244 : blume 281 fun convert { tree, err } = let
245 :     (* build a function that will complain (once you call it)
246 :     * about any existing restriction violations *)
247 :     fun newReg reg = let
248 :     fun sameReg (LocalDec (_, body), k) = sameReg (body, k)
249 :     | sameReg (SeqDec l, k) = foldl sameReg k l
250 :     | sameReg (OpenDec _, k) =
251 :     (fn () => (k (); err EM.COMPLAIN reg "toplevel open"))
252 :     | sameReg (MarkDec (arg, reg), k) = newReg reg (arg, k)
253 :     | sameReg ((StrDec _ | AbsDec _ | FctDec _ | SigDec _ |
254 :     FsigDec _), k) = k
255 :     | sameReg (_, k) =
256 :     (fn () =>
257 :     (k (); err EM.WARN reg "definition not tracked by CM"))
258 :    
259 :     in
260 :     sameReg
261 :     end
262 : blume 275 in
263 : blume 286 { complain = newReg (0, 0) (tree, fn () => ()),
264 :     skeleton = SkelOpt.opt (c_dec tree) }
265 : blume 275 end
266 :     end

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