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

Legend:
Removed from v.281  
changed lines
  Added in v.286

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