Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/smlfile/skel-cvt.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 290, Sat May 22 21:01:25 1999 UTC revision 291, Mon May 24 09:41:07 1999 UTC
# Line 32  Line 32 
32      fun (f o' g) (x, y) = f (g x, y)      fun (f o' g) (x, y) = f (g x, y)
33    
34      (* given a path, add an element to a set of module references *)      (* given a path, add an element to a set of module references *)
35      fun s_addP ([], a) = a              (* can this happen at all? *)      (* here we always ignore the last component -- it is not supposed to
36        | s_addP ([only], a) = a          (* no module name here *)       * be a module (we could actually check, but we know from context) *)
37        | s_addP (head :: _, a) = SS.add (a, head)      fun s_addMP ([], set) = set         (* can this happen at all? *)
38          | s_addMP ([only], set) = set     (* no module name here *)
39      (* given a path, add an element to a decl list *)        | s_addMP (head :: _, set) = SS.add (set, head)
40      fun d_addP ([], a) = a  
41        | d_addP (h :: _, []) = [Ref (SS.singleton h)]      (* add a reference to a symbol to a dl *)
42        | d_addP (h :: _, Ref s :: a) = Ref (SS.add (s, h)) :: a      fun dl_addSym (sy, []) = [Ref (SS.singleton sy)]
43        | d_addP (h :: _, a) = Ref (SS.singleton h) :: a        | dl_addSym (sy, Ref s :: dl) = Ref (SS.add (s, sy)) :: dl
44          | dl_addSym (sy, dl) = Ref (SS.singleton sy) :: dl
45    
46        (* add the first element of a path to a dl *)
47        fun dl_addP ([], d) = d
48          | dl_addP (head :: _, d) = dl_addSym (head, d)
49    
50        (* add the first element of a path to a dl -- except if that element is
51         * the only one on the path*)
52        fun dl_addMP ([], dl) = dl
53          | dl_addMP ([only], dl) = dl
54          | dl_addMP (head :: _, dl) = dl_addSym (head, dl)
55    
56      (* given a set of module references, add it to a decl list *)      (* given a set of module references, add it to a decl list *)
57      fun d_addS (s, a) =      fun dl_addS (s, a) =
58          if SS.isEmpty s then a          if SS.isEmpty s then a
59          else case a of          else case a of
60              [] => [Ref s]              [] => [Ref s]
61            | Ref s' :: a => Ref (SS.union (s, s')) :: a            | Ref s' :: a => Ref (SS.union (s, s')) :: a
62            | a => Ref s :: a            | a => Ref s :: a
63    
64      fun localDec ([], [], a) = a      (* split initial ref set from a decl list *)
65        | localDec ([], [Ref s], a) = d_addS (s, a)      fun split_dl [] = (SS.empty, [])
66        | localDec (Ref s :: t, body, a) = d_addS (s, localDec (t, body, a))        | split_dl (Ref s :: d) = (s, d)
67        | localDec (bdg, body, a) = Local (Seq bdg, Seq body) :: a        | split_dl d = (SS.empty, d)
68    
69      fun con (s1, NONE) = s1      (* join two definition sequences *)
70        | con (s1, SOME s2) = Con (s1, s2)      fun join_dl ([], d) = d
71          | join_dl ([Ref s], d) = dl_addS (s, d)
72      fun c_dec ast = Seq (do_dec (ast, []))        | join_dl (h :: t, d) = h :: join_dl (t, d)
73    
74      and do_dec (ValDec (l, _), a) = foldr c_vb a l      (* local definitions *)
75        | do_dec (ValrecDec (l, _), a) = foldr c_rvb a l      fun local_dl ([], b, d) = join_dl (b, d)
76        | do_dec (FunDec (l, _), a) = foldr c_fb a l        | local_dl (Ref s :: t, b, d) = dl_addS (s, local_dl (t, b, d))
77        | do_dec (TypeDec l, a) = d_addS (foldl c_tb SS.empty l, a)        | local_dl (l, b, d) = Local (Seq l, Seq b) :: d
78        | do_dec (DatatypeDec { datatycs, withtycs }, a) =  
79          d_addS (foldl c_db (foldl c_tb SS.empty withtycs) datatycs, a)      (* build a let expression *)
80        | do_dec (AbstypeDec { abstycs, withtycs, body }, a) =      fun letexp (dl, (s, e)) =
81          (* body is syntactically restricted to ldecs,          case split_dl dl of
82           * no module scoping here *)              (s', []) => (SS.union (s', s), e)
83          d_addS (foldl c_db (foldl c_tb SS.empty withtycs) abstycs,            | (s', dl') => let
84                  c_dec body :: a)                  val dl'' = if SS.isEmpty s then dl'
85        | do_dec (ExceptionDec l, a) = d_addS (foldl c_eb SS.empty l, a)                             else rev (dl_addS (s, rev dl'))
86        | do_dec ((StrDec l | AbsDec l), a) = Par (foldr c_strb [] l) :: a              in
87        | do_dec (FctDec l, a) = Par (foldr c_fctb [] l) :: a                  (s', Let (Seq dl'', e))
88        | do_dec (SigDec l, a) = Par (foldr c_sigb [] l) :: a              end
89        | do_dec (FsigDec l, a) = Par (foldr c_fsigb [] l) :: a  
90        | do_dec (LocalDec (bdg, body), a) =      (* making a Ign1 where necessary ... *)
91          localDec (do_dec (bdg, []), do_dec (body, []), a)      fun ign (p1, NONE) = p1
92        | do_dec (SeqDec l, a) = foldr do_dec a l        | ign ((s1, e1), SOME (s2, e2)) = (SS.union (s1, s2), Ign1 (e1, e2))
93        | do_dec (OpenDec l, a) = Par (map (Open o Var o SP.SPATH) l) :: a  
94        | do_dec ((OvldDec _ | FixDec _), a) = a      (* generate a set of "parallel" bindings *)
95        | do_dec (MarkDec (arg, _), a) = do_dec (arg, a)      fun parbind f l d = let
96            val (s, bl) = foldl f (SS.empty, []) l
97      and c_strb (Strb { name, def, constraint }, a) =      in
98          Bind (name, con (c_strexp def, sigexpConst constraint)) :: a          dl_addS (s, Par bl :: d)
99        | c_strb (MarkStrb (arg, _), a) = c_strb (arg, a)      end
100    
101      and c_fctb (Fctb { name, def }, a) = Bind (name, c_fctexp def) :: a      (* get the ref set from a type *)
102        | c_fctb (MarkFctb (arg, _), a) = c_fctb (arg, a)      fun ty_s (VarTy _, set) = set
103          | ty_s (ConTy (cn, l), set) = s_addMP (cn, foldl ty_s set l)
104      and c_sigb (Sigb { name, def }, a) = Bind (name, c_sigexp def) :: a        | ty_s (RecordTy l, set) = foldl (ty_s o' #2) set l
105        | c_sigb (MarkSigb (arg, _), a) = c_sigb (arg, a)        | ty_s (TupleTy l, set) = foldl ty_s set l
106          | ty_s (MarkTy (arg, _), set) = ty_s (arg, set)
107      and c_fsigb (Fsigb { name, def }, a) = Bind (name, c_fsigexp def) :: a  
108        | c_fsigb (MarkFsigb (arg, _), a) = c_fsigb (arg, a)      (* ... from a type option *)
109        fun tyopt_s (NONE, set) = set
110      and c_strexp (VarStr path) = Var (SP.SPATH path)        | tyopt_s (SOME t, set) = ty_s (t, set)
111        | c_strexp (BaseStr dec) = Decl (c_dec dec)  
112        | c_strexp (ConstrainedStr (s, NoSig)) = c_strexp s      (* ... from a pattern *)
113        | c_strexp (ConstrainedStr (s, (Transparent g | Opaque g))) =      fun pat_s (VarPat p, set) = s_addMP (p, set)
114          Con (c_strexp s, c_sigexp g)        | pat_s (RecordPat { def, ... }, set) = foldl (pat_s o' #2) set def
115        | c_strexp (AppStr (p, l) | AppStrI (p, l)) =        | pat_s ((ListPat l | TuplePat l | VectorPat l | OrPat l), set) =
116          App (SP.SPATH p, map (c_strexp o #1) l)          foldl pat_s set l
117        | c_strexp (LetStr (bdg, body)) = Let (c_dec bdg, c_strexp body)        | pat_s (FlatAppPat l, set) = foldl (pat_s o' #item) set l
118        | c_strexp (MarkStr (s, _)) = c_strexp s        | pat_s (AppPat { constr, argument }, set) =
119            pat_s (constr, pat_s (argument, set))
120      and c_fctexp (VarFct (p, c)) = con (Var (SP.SPATH p), fsigexpConst c)        | pat_s (ConstraintPat { pattern, constraint }, set) =
121        | c_fctexp (BaseFct { params = p, body = b, constraint = c }) =          pat_s (pattern, ty_s (constraint, set))
122          Let (Seq (map functorParams p), con (c_strexp b, sigexpConst c))        | pat_s (LayeredPat { varPat, expPat }, set) =
123        | c_fctexp (AppFct (p, l, c)) =          pat_s (varPat, pat_s (expPat, set))
124          con (App (SP.SPATH p, map (c_strexp o #1) l), fsigexpConst c)        | pat_s (MarkPat (arg, _), set) = pat_s (arg, set)
125        | c_fctexp (LetFct (bdg, body)) = Let (c_dec bdg, c_fctexp body)        | pat_s ((WildPat|IntPat _|WordPat _|StringPat _|CharPat _), set) = set
126        | c_fctexp (MarkFct (arg, _)) = c_fctexp arg  
127        (* ... from an exception binding *)
128      and functorParams (NONE, c) = Open (c_sigexp c)      fun eb_s (EbGen { exn, etype }, set) = tyopt_s (etype, set)
129        | functorParams (SOME s, c) = Bind (s, c_sigexp c)        | eb_s (EbDef { exn, edef }, set) = s_addMP (edef, set)
130          | eb_s (MarkEb (arg, _), set) = eb_s (arg, set)
131      and sigexpConst NoSig = NONE  
132        | sigexpConst (Transparent g | Opaque g) = SOME (c_sigexp g)      (* ... *)
133        fun dbrhs_s (Constrs l, set) = foldl (tyopt_s o' #2) set l
134      and c_sigexp (VarSig s) = Var (SP.SPATH [s])        | dbrhs_s (Repl cn, set) = s_addMP (cn, set)
135        | c_sigexp (AugSig (g, whspecs)) = let  
136              fun f (WhType (_, _, ty), x) = c_ty (ty, x)      fun db_s (Db { tyc, tyvars, rhs, lazyp }, set) = dbrhs_s (rhs, set)
137                | f (WhStruct (_, head :: _), x) = SS.add (x, head)        | db_s (MarkDb (arg, _), set) = db_s (arg, set)
138                | f _ = raise Fail "skel-cvt/c_sigexp"  
139          in      fun tb_s (Tb { tyc, def, tyvars }, set) = ty_s (def, set)
140              Let (Ref (foldl f SS.empty whspecs), c_sigexp g)        | tb_s (MarkTb (arg, _), set) = tb_s (arg, set)
141          end  
142        | c_sigexp (BaseSig l) = Decl (Seq (foldr c_spec [] l))      (* get a dl from an expression... *)
143        | c_sigexp (MarkSig (arg, _)) = c_sigexp arg      fun exp_dl (VarExp p, d) = dl_addMP (p, d)
144          | exp_dl (FnExp rl, d) = foldr rule_dl d rl
145      and fsigexpConst NoSig = NONE        | exp_dl (FlatAppExp l, d) = foldr (exp_dl o' #item) d l
146        | fsigexpConst (Transparent fg | Opaque fg) = SOME (c_fsigexp fg)        | exp_dl (AppExp { function, argument }, d) =
147            exp_dl (function, exp_dl (argument, d))
148      and c_fsigexp (VarFsig s) = Var (SP.SPATH [s])        | exp_dl (CaseExp { expr, rules }, d) =
149        | c_fsigexp (BaseFsig { param, result }) =          exp_dl (expr, foldr rule_dl d rules)
150          Let (Seq (map functorParams param), c_sigexp result)        | exp_dl (LetExp { dec, expr }, d) =
151        | c_fsigexp (MarkFsig (arg, _)) = c_fsigexp arg          local_dl (dec_dl (dec, []), exp_dl (expr, []), d)
152          | exp_dl ((SeqExp l | ListExp l | TupleExp l | VectorExp l), d) =
153      and c_spec (StrSpec l, a) = let          foldl exp_dl d l
154              fun f (s, g, c) =        | exp_dl (RecordExp l, d) = foldl (exp_dl o' #2) d l
155                  Bind (s, con (c_sigexp g, Option.map (Var o SP.SPATH) c))        | exp_dl (SelectorExp _, d) = d
156          in        | exp_dl (ConstraintExp { expr, constraint }, d) =
157              (Par (map f l)) :: a          dl_addS (ty_s (constraint, SS.empty), exp_dl (expr, d))
158          end        | exp_dl (HandleExp { expr, rules }, d) =
159        | c_spec (TycSpec (l, _), a) = let          exp_dl (expr, foldl rule_dl d rules)
160              fun f ((_, _, SOME t), s) = c_ty (t, s)        | exp_dl (RaiseExp e, d) = exp_dl (e, d)
161                | f (_, s) = s        | exp_dl (IfExp { test, thenCase, elseCase }, d) =
162          in          exp_dl (test, exp_dl (thenCase, exp_dl (elseCase, d)))
163              d_addS (foldl f SS.empty l, a)        | exp_dl ((AndalsoExp (e1, e2) | OrelseExp (e1, e2)), d) =
164          end          exp_dl (e1, exp_dl (e2, d))
165        | c_spec (FctSpec l, a) =        | exp_dl (WhileExp { test, expr }, d) = exp_dl (test, exp_dl (expr, d))
166          Par (map (fn (s, g) => Bind (s, c_fsigexp g)) l) :: a        | exp_dl (MarkExp (arg, _), d) = exp_dl (arg, d)
167        | c_spec (ValSpec l, a) = d_addS (foldl (c_ty o' #2) SS.empty l, a)        | exp_dl ((IntExp _|WordExp _|RealExp _|StringExp _|CharExp _), d) = d
168        | c_spec (DataSpec { datatycs, withtycs }, a) =  
169          d_addS (foldl c_db (foldl c_tb SS.empty withtycs) datatycs, a)      and rule_dl (Rule { pat, exp }, d) =
170        | c_spec (ExceSpec l, a) = d_addS (foldl (tyoption o' #2) SS.empty l, a)          dl_addS (pat_s (pat, SS.empty), exp_dl (exp, d))
171        | c_spec (ShareStrSpec l, a) = foldl d_addP a l  
172        | c_spec (ShareTycSpec l, a) = d_addS (foldl s_addP SS.empty l, a)      and clause_dl (Clause { pats = p, resultty = t, exp = e }, d) =
173        | c_spec (IncludeSpec g, a) = Open (c_sigexp g) :: a          dl_addS (foldl (pat_s o' #item) (tyopt_s (t, SS.empty)) p,
174        | c_spec (MarkSpec (arg, _), a) = c_spec (arg, a)                  exp_dl (e, d))
175    
176      and c_vb (Vb { pat, exp, lazyp }, a) =      and fb_dl (Fb (l, _), d) = foldr clause_dl d l
177          d_addS (c_pat (pat, SS.empty), c_exp (exp, a))        | fb_dl (MarkFb (arg, _), d) = fb_dl (arg, d)
178        | c_vb (MarkVb (arg, _), a) = c_vb (arg, a)  
179        and vb_dl (Vb { pat, exp, lazyp }, d) =
180      and c_rvb (Rvb { var, exp, resultty, ... }, a) =          dl_addS (pat_s (pat, SS.empty), exp_dl (exp, d))
181          d_addS (tyoption (resultty, SS.empty), c_exp (exp, a))        | vb_dl (MarkVb (arg, _), d) = vb_dl (arg, d)
182        | c_rvb (MarkRvb (arg, _), a) = c_rvb (arg, a)  
183        and rvb_dl (Rvb { var, exp, resultty, ... }, d) =
184      and c_fb (Fb (l, _), a) = foldr c_clause a l          dl_addS (tyopt_s (resultty, SS.empty), exp_dl (exp, d))
185        | c_fb (MarkFb (arg, _), a) = c_fb (arg, a)        | rvb_dl (MarkRvb (arg, _), d) = rvb_dl (arg, d)
186    
187      and c_clause (Clause { pats = p, resultty = t, exp = e }, a) =      and spec_dl (MarkSpec (arg, _), d) = spec_dl (arg, d)
188          d_addS (foldl (c_pat o' #item) (tyoption (t, SS.empty)) p,        | spec_dl (StrSpec l, d) = let
189                  c_exp (e, a))              (* this is strange: signature is not optional! *)
190                fun one ((n, g, c), (s, bl)) = let
191      and c_tb (Tb { tyc, def, tyvars }, a) = c_ty (def, a)                  val (s', e) = sigexp_p g
192        | c_tb (MarkTb (arg, _), a) = c_tb (arg, a)                  val s'' = SS.union (s, s')
193                in
194      and c_db (Db { tyc, tyvars, rhs, lazyp }, a) = c_dbrhs (rhs, a)                  case c of
195        | c_db (MarkDb (arg, _), a) = c_db (arg, a)                      NONE => (s'', Bind (n, e) :: bl)
196                      | SOME p => (s'', Bind (n, Ign1 (Var (SP.SPATH p), e)) :: bl)
197      and c_dbrhs (Constrs def, a) = foldl (tyoption o' #2) a def              end
198        | c_dbrhs (Repl cn, a) = s_addP (cn, a)              val (s, bl) = foldr one (SS.empty, []) l
199            in
200      and c_eb (EbGen { exn, etype }, a) = tyoption (etype, a)              dl_addS (s, Par bl :: d)
201        | c_eb (EbDef { exn, edef }, a) = s_addP (edef, a)          end
202        | c_eb (MarkEb (arg, _), a) = c_eb (arg, a)        | spec_dl (TycSpec (l, _), d) = let
203                fun one_s ((_, _, SOME t), s) = ty_s (t, s)
204      and c_exp (VarExp p, a) = d_addP (p, a)                | one_s (_, s) = s
205        | c_exp (FnExp arg, a) = foldr c_rule a arg          in
206        | c_exp (FlatAppExp l, a) = foldr (c_exp o' #item) a l              dl_addS (foldl one_s SS.empty l, d)
207        | c_exp (AppExp { function, argument }, a) =          end
208          c_exp (function, c_exp (argument, a))        | spec_dl (FctSpec l, d) = let
209        | c_exp (CaseExp { expr, rules }, a) = c_exp (expr, foldr c_rule a rules)              fun one ((n, g), (s, bl)) = let
210        | c_exp (LetExp { dec, expr }, a) =                  val (s', e) = fsigexp_p g
211          localDec (do_dec (dec, []), c_exp (expr, []), a)              in
212        | c_exp ((SeqExp l | ListExp l | TupleExp l | VectorExp l), a) =                  (SS.union (s, s'), Bind (n, e) :: bl)
213          foldr c_exp a l              end
214        | c_exp (RecordExp l, a) = foldr (c_exp o' #2) a l              val (s, bl) = foldr one (SS.empty, []) l
215        | c_exp (SelectorExp _, a) = a          in
216        | c_exp (ConstraintExp { expr, constraint }, a) =              dl_addS (s, Par bl :: d)
217          c_exp (expr, d_addS (c_ty (constraint, SS.empty), a))          end
218        | c_exp (HandleExp { expr, rules }, a) =        | spec_dl (ValSpec l, d) = dl_addS (foldl (ty_s o' #2) SS.empty l, d)
219          c_exp (expr, foldr c_rule a rules)        | spec_dl (DataSpec { datatycs, withtycs }, d) =
220        | c_exp (RaiseExp e, a) = c_exp (e, a)          dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) datatycs, d)
221        | c_exp (IfExp { test, thenCase, elseCase }, a) =        | spec_dl (ExceSpec l, d) = dl_addS (foldl (tyopt_s o' #2) SS.empty l, d)
222          c_exp (test, c_exp (thenCase, c_exp (elseCase, a)))        | spec_dl (ShareStrSpec l, d) = foldl dl_addP d l
223        | c_exp ((AndalsoExp (e1, e2) | OrelseExp (e1, e2)), a) =        | spec_dl (ShareTycSpec l, d) = dl_addS (foldl s_addMP SS.empty l, d)
224          c_exp (e1, c_exp (e2, a))        | spec_dl (IncludeSpec g, d) = let
225        | c_exp (WhileExp { test, expr }, a) = c_exp (test, c_exp (expr, a))              val (s, e) = sigexp_p g
226        | c_exp (MarkExp (arg, _), a) = c_exp (arg, a)          in
227        | c_exp ((IntExp _|WordExp _|RealExp _|StringExp _|CharExp _), a) = a              dl_addS (s, Open e :: d)
228            end
229      and c_rule (Rule { pat, exp }, a) =  
230          d_addS (c_pat (pat, SS.empty), c_exp (exp, a))      and sigexp_p (VarSig s) = (SS.empty, Var (SP.SPATH [s]))
231          | sigexp_p (AugSig (g, whspecs)) = let
232      and c_pat (VarPat p, a) = s_addP (p, a)              fun one_s (WhType (_, _, ty), s) = ty_s (ty, s)
233        | c_pat (RecordPat { def, ... }, a) = foldl (c_pat o' #2) a def                | one_s (WhStruct (_, head :: _), s) = SS.add (s, head)
234        | c_pat ((ListPat l | TuplePat l | VectorPat l | OrPat l), a) =                | one_s _ = raise Fail "skel-cvt/sigexp_p"
235          foldl c_pat a l              val (s, e) = sigexp_p g
236        | c_pat (FlatAppPat l, a) = foldl (c_pat o' #item) a l          in
237        | c_pat (AppPat { constr, argument }, a) =              (foldl one_s s whspecs, e)
238          c_pat (constr, c_pat (argument, a))          end
239        | c_pat (ConstraintPat { pattern, constraint }, a) =        | sigexp_p (BaseSig l) = let
240          c_pat (pattern, c_ty (constraint, a))              val (s, d) = split_dl (foldr spec_dl [] l)
241        | c_pat (LayeredPat { varPat, expPat }, a) =          in
242          c_pat (varPat, c_pat (expPat, a))              (s, Decl (Seq d))
243        | c_pat (MarkPat (arg, _), a) = c_pat (arg, a)          end
244        | c_pat ((WildPat|IntPat _|WordPat _|StringPat _|CharPat _), a) = a        | sigexp_p (MarkSig (arg, _)) = sigexp_p arg
245    
246      and c_ty (VarTy _, a) = a      and fsigexp_p (VarFsig s) = (SS.empty, Var (SP.SPATH [s]))
247        | c_ty (ConTy (cn, l), a) = s_addP (cn, foldl c_ty a l)        | fsigexp_p (BaseFsig { param, result }) =
248        | c_ty (RecordTy l, a) = foldl (c_ty o' #2) a l          letexp (foldr fparam_d [] param, sigexp_p result)
249        | c_ty (TupleTy l, a) = foldl c_ty a l        | fsigexp_p (MarkFsig (arg, _)) = fsigexp_p arg
250        | c_ty (MarkTy (arg, _), a) = c_ty (arg, a)  
251        and fparam_d ((nopt, g), d) = let
252            val (s, e) = sigexp_p g
253        in
254            case nopt of
255                NONE => dl_addS (s, Open e :: d)
256              | SOME n => dl_addS (s, Bind (n, e) :: d)
257        end
258    
259        and sigexpc_p NoSig = NONE
260          | sigexpc_p (Transparent g | Opaque g) = SOME (sigexp_p g)
261    
262        and fsigexpc_p NoSig = NONE
263          | fsigexpc_p (Transparent fg | Opaque fg) = SOME (fsigexp_p fg)
264    
265        and fctexp_p (VarFct (p, c)) =
266            ign ((SS.empty, Var (SP.SPATH p)), fsigexpc_p c)
267          | fctexp_p (BaseFct { params, body, constraint }) =
268            letexp (foldr fparam_d [] params,
269                    ign (strexp_p body, sigexpc_p constraint))
270          | fctexp_p (AppFct (p, l, c)) = let
271                fun one ((str, _), (s, el)) = let
272                    val (s', e) = strexp_p str
273                in
274                    (SS.union (s, s'), e :: el)
275                end
276                val (s, el) = foldl one (SS.empty, []) l
277                val (s', e) = ign ((SS.empty, Var (SP.SPATH p)), fsigexpc_p c)
278            in
279                (SS.union (s, s'), foldl Ign1 e el)
280            end
281          | fctexp_p (LetFct (bdg, b)) = letexp (dec_dl (bdg, []), fctexp_p b)
282          | fctexp_p (MarkFct (arg, _)) = fctexp_p arg
283    
284        and strexp_p (VarStr p) = (SS.empty, Var (SP.SPATH p))
285          | strexp_p (BaseStr dec) = let
286                val (s, dl) = split_dl (dec_dl (dec, []))
287            in
288                (s, Decl (Seq dl))
289            end
290          | strexp_p (ConstrainedStr (s, c)) = ign (strexp_p s, sigexpc_p c)
291          | strexp_p (AppStr (p, l) | AppStrI (p, l)) = let
292                fun one ((str, _), (s, el)) = let
293                    val (s', e) = strexp_p str
294                in
295                    (SS.union (s, s'), e :: el)
296                end
297                val (s, el) = foldl one (SS.empty, []) l
298            in
299                (s, foldl Ign1 (Var (SP.SPATH p)) el)
300            end
301          | strexp_p (LetStr (bdg, b)) = letexp (dec_dl (bdg, []), strexp_p b)
302          | strexp_p (MarkStr (s, _)) = strexp_p s
303    
304        and dec_dl (ValDec (l, _), d) = foldl vb_dl d l
305          | dec_dl (ValrecDec (l, _), d) = foldl rvb_dl d l
306          | dec_dl (FunDec (l, _), d) = foldl fb_dl d l
307          | dec_dl (TypeDec l, d) = dl_addS (foldl tb_s SS.empty l, d)
308          | dec_dl (DatatypeDec { datatycs, withtycs }, d) =
309            dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) datatycs, d)
310          | dec_dl (AbstypeDec { abstycs, withtycs, body }, d) =
311            dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) abstycs,
312                     dec_dl (body, d))
313          | dec_dl (ExceptionDec l, d) = dl_addS (foldl eb_s SS.empty l, d)
314          | dec_dl ((StrDec l | AbsDec l), d) = let
315                fun one (MarkStrb (arg, _), x) = one (arg, x)
316                  | one (Strb { name, def, constraint }, (s, bl)) = let
317                        val (s', e) = ign (strexp_p def, sigexpc_p constraint)
318                    in
319                        (SS.union (s, s'), Bind (name, e) :: bl)
320                    end
321            in
322                parbind one l d
323            end
324          | dec_dl (FctDec l, d) = let
325                fun one (MarkFctb (arg, _), x) = one (arg, x)
326                  | one (Fctb { name, def }, (s, bl)) = let
327                        val (s', e) = fctexp_p def
328                    in
329                        (SS.union (s, s'), Bind (name, e) :: bl)
330                    end
331            in
332                parbind one l d
333            end
334          | dec_dl (SigDec l, d) = let
335                fun one (MarkSigb (arg, _), x) = one (arg, x)
336                  | one (Sigb { name, def }, (s, bl)) = let
337                        val (s', e) = sigexp_p def
338                    in
339                        (SS.union (s, s'), Bind (name, e) :: bl)
340                    end
341            in
342                parbind one l d
343            end
344          | dec_dl (FsigDec l, d) = let
345                fun one (MarkFsigb (arg, _), x) = one (arg, x)
346                  | one (Fsigb { name, def }, (s, bl)) = let
347                        val (s', e) = fsigexp_p def
348                    in
349                        (SS.union (s, s'), Bind (name, e) :: bl)
350                    end
351            in
352                parbind one l d
353            end
354          | dec_dl (LocalDec (bdg, body), d) =
355            local_dl (dec_dl (bdg, []), dec_dl (body, []), d)
356          | dec_dl (SeqDec l, d) = foldr dec_dl d l
357          | dec_dl (OpenDec l, d) = Par (map (Open o Var o SP.SPATH) l) :: d
358          | dec_dl ((OvldDec _ | FixDec _), d) = d
359          | dec_dl (MarkDec (arg, _), d) = dec_dl (arg, d)
360    
361      and tyoption (NONE, a) = a      fun c_dec d = Seq (dec_dl (d, []))
       | tyoption (SOME ty, a) = c_ty (ty, a)  
362    
363      fun convert { tree, err } = let      fun convert { tree, err } = let
364          (* build a function that will complain (once you call it)          (* build a function that will complain (once you call it)
# Line 260  Line 379 
379              sameReg              sameReg
380          end          end
381      in      in
382          { complain = newReg (0, 0) (tree, fn () => ()),          { complain = newReg (0, 0) (tree, fn () => ()), skeleton = c_dec tree }
           skeleton = SkelOpt.opt (c_dec tree) }  
383      end      end
384  end  end

Legend:
Removed from v.290  
changed lines
  Added in v.291

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