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

Diff of /sml/branches/SMLNJ/src/cm/smlfile/skel-cvt.sml

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

revision 629, Wed Apr 26 04:06:41 2000 UTC revision 630, Wed Apr 26 18:40:56 2000 UTC
# Line 1  Line 1 
1  (*  (*
2   * Convert ASTs to CM's trimmed version thereof.   * Convert ASTs to CM's trimmed version thereof ("skeletons").
3   *   *
4     *   Copyright (c) 1999 by Lucent Technologies, Bell Laboratories
5     *
6     *   The ideas here are based on those found in the original SC and
7     *   also in an older version of CM (before 1999).  However, nearly
8     *   all aspects have been changed radically, and the code has been
9     *   re-written from scratch.
10     *
11     *   The skeletons generated by this module are typically smaller
12     *   than the "decl"s in SC or old versions of CM.  This should
13     *   make dependency analysis somewhat faster (but is probably not
14     *   very noticeable).
15     *
16     * author: Matthias Blume (blume@cs.princeton.edu)
17     *
18     * The copyright notices of the earlier versions are:
19   *   Copyright (c) 1995 by AT&T Bell Laboratories   *   Copyright (c) 1995 by AT&T Bell Laboratories
20   *   Copyright (c) 1993 by Carnegie Mellon University,   *   Copyright (c) 1993 by Carnegie Mellon University,
21   *                         School of Computer Science   *                         School of Computer Science
22   *                         contact: Gene Rollins (rollins+@cs.cmu.edu)   *                         contact: Gene Rollins (rollins+@cs.cmu.edu)
  *  
  * contact: Matthias Blume (blume@cs.princeton.edu)  
23   *)   *)
24  signature SKELCVT = sig  signature SKELCVT = sig
25      val convert : { tree: GenericVC.Ast.dec,      val convert : { tree: GenericVC.Ast.dec,
26                      err: GenericVC.ErrorMsg.severity ->                      err: GenericVC.ErrorMsg.severity ->
27                           GenericVC.Ast.region -> string -> unit }                           GenericVC.Ast.region -> string -> unit }
28          -> Skeleton.decl          -> { skeleton : Skeleton.decl, complain : unit -> unit }
29  end  end
30    
31  structure SkelCvt :> SKELCVT = struct  structure SkelCvt :> SKELCVT = struct
32    
33      open GenericVC.Ast Skeleton      open GenericVC.Ast Skeleton
34    
35      structure S = GenericVC.Symbol      structure S = Symbol
36      structure SP = GenericVC.SymPath      structure SP = GenericVC.SymPath
37      structure SS = SymbolSet      structure SS = SymbolSet
38      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
39    
40      val symbolModPath = SP.SPATH      type symbol = Symbol.symbol
   
     type symbol = GenericVC.Symbol.symbol  
41      type path = symbol list      type path = symbol list
42    
43      fun allButLast lst =      (* The main idea is to collect lists of decl ("dl"s).
44          case lst of       * Normally, a dl will eventually become an argument to seq or par.
45              [] => []       * As an important optimization, we always try to keep any "Ref s"
46            | [last] => []       * at the front (but we don't try too hard and only do it where
47            | head :: (tail as (_ :: _)) => head :: (allButLast tail)       * it is reasonably convenient). *)
48    
49      fun modRef (path, accum) =      (* function composition suitable for fold[lr]-arguments *)
50          case path of [] => accum      infix o'
51        | [only] => accum      fun (f o' g) (x, y) = f (g x, y)
52        | head :: _ => SS.add (accum, head)  
53        (* add the head of a symbol path to a given set *)
54      fun declRef (path, accum) =      fun s_addP ([], set) = set
55          case path of        | s_addP (head :: _, set) = SS.add (set, head)
56              [] => accum  
57            | head :: _ =>      (* same as s_addP except we ignore paths of length 1 because they
58                  (case accum of       * do not involve module access. *)
59                       [] => [DeclRef (SS.singleton head)]      fun s_addMP ([], set) = set         (* can this happen at all? *)
60                     | (DeclRef otherRefs) :: tail =>        | s_addMP ([only], set) = set     (* no module name here *)
61                           (DeclRef (SS.add (otherRefs, head))) :: tail        | s_addMP (head :: _, set) = SS.add (set, head)
62                     | _ => (DeclRef (SS.singleton head)) :: accum)  
63        (* add a reference to a symbol to a dl *)
64      fun dropLast [x] = nil      fun dl_addSym (sy, []) = [Ref (SS.singleton sy)]
65        | dropLast [] = []        | dl_addSym (sy, Ref s :: dl) = Ref (SS.add (s, sy)) :: dl
66        | dropLast (a :: rest) = a :: (dropLast rest)        | dl_addSym (sy, dl) = Ref (SS.singleton sy) :: dl
67    
68      fun modRefSet (modNames, accum) =      (* add the first element of a path to a dl *)
69          if SS.isEmpty modNames then accum      fun dl_addP ([], d) = d
70          else        | dl_addP (head :: _, d) = dl_addSym (head, d)
71              case accum of  
72                  [] => [DeclRef modNames]      (* add the first element of a path to a dl -- except if that element is
73                | (DeclRef otherRefs) :: tail =>       * the only one on the path*)
74                      (DeclRef (SS.union (modNames, otherRefs))) :: tail      fun dl_addMP ([], dl) = dl
75                | _ => (DeclRef modNames) :: accum        | dl_addMP ([only], dl) = dl
76          | dl_addMP (head :: _, dl) = dl_addSym (head, dl)
77      fun localDec ((bind, body), accum) =  
78          case (bind, body) of      (* given a set of module references, add it to a decl list *)
79              ([], []) => accum      fun dl_addS (s, dl) =
80            | ([], [DeclRef names]) => modRefSet (names, accum)          if SS.isEmpty s then dl
81            | ([DeclRef names], []) => modRefSet (names, accum)          else case dl of
82            | ([DeclRef names1], [DeclRef names2]) =>              [] => [Ref s]
83                  modRefSet (SS.union (names1, names2), accum)            | Ref s' :: dl' => Ref (SS.union (s, s')) :: dl'
84            | args => (LocalDecl (SeqDecl bind, SeqDecl body)) :: accum            | _ => Ref s :: dl
85    
86      fun c_dec ast =      (* make a Seq node when necessary *)
87          case do_dec (ast, []) of      fun seq [] = Ref SS.empty
88              [] => DeclRef SS.empty        | seq [only] = only
89            | [decl] => decl        | seq l = Seq l
90            | declList => SeqDecl declList  
91        (* make a Par node when necessary and stick it in front of a given dl *)
92      and do_dec (ast, accum) =      fun parcons ([], d) = d
93          case ast of        | parcons ([only], d) = only :: d
94              ValDec (arg, _) => foldr c_vb accum arg        | parcons (l, d) = Par l :: d
95            | ValrecDec (arg, _) => foldr c_rvb accum arg  
96            | FunDec (arg, _) => foldr c_fb accum arg      (* Given a "bind list", stick a parallel Bind in front of a given dl.
97            | TypeDec arg => modRefSet (foldr c_tb SS.empty arg, accum)       * While doing so, if a Ref occured at the front of the dl, move it
98            | DatatypeDec { datatycs, withtycs } =>       * past the bind list (shrinking it appropriately). *)
99                  modRefSet (foldr c_db (foldr c_tb SS.empty withtycs) datatycs,      fun parbindcons (bl, Ref s :: d) = let
100                             accum)              val bs = SS.addList (SS.empty, map #1 bl)
101            | AbstypeDec { abstycs, withtycs, body } =>          in
102                  (* body is syntactically restricted to ldecs,              dl_addS (SS.difference (s, bs), parcons (map Bind bl, d))
103                   * no module scoping here *)          end
104                  modRefSet (foldr c_db (foldr c_tb SS.empty withtycs) abstycs,        | parbindcons (bl, d) = parcons (map Bind bl, d)
105                             (c_dec body) :: accum)  
106            | ExceptionDec arg =>      (* split initial ref set from a decl list *)
107                  modRefSet (foldr c_eb SS.empty arg, accum)      fun split_dl [] = (SS.empty, [])
108            | StrDec arg => (StrDecl (foldr c_strb [] arg)) :: accum        | split_dl (Ref s :: d) = (s, d)
109            | AbsDec arg => (StrDecl (foldr c_strb [] arg)) :: accum        | split_dl d = (SS.empty, d)
110            | FctDec arg => (FctDecl (foldr c_fctb [] arg)) :: accum  
111            | SigDec arg => (StrDecl (foldr c_sigb [] arg)) :: accum      (* join two definition sequences *)
112            | FsigDec arg => (FctDecl (foldr c_fsigb [] arg)) :: accum      fun join_dl ([], d) = d
113            | LocalDec (bindingDec, bodyDec) =>        | join_dl ([Ref s], d) = dl_addS (s, d)
114                  localDec ((do_dec (bindingDec, []),        | join_dl (h :: t, d) = h :: join_dl (t, d)
115                             do_dec (bodyDec, [])),  
116                            accum)      (* local definitions *)
117            | SeqDec arg => foldr do_dec accum arg      fun local_dl ([], b, d) = join_dl (b, d)
118            | OpenDec arg =>        | local_dl (Ref s :: t, b, d) = dl_addS (s, local_dl (t, b, d))
119                  (OpenDecl (map (VarStrExp o symbolModPath) arg)) :: accum        | local_dl (l, b, d) = Local (seq l, seq b) :: d
120            | OvldDec arg => accum  
121            | FixDec arg => accum      (* build a let expression *)
122            | MarkDec (arg, _) => do_dec (arg, accum)      fun letexp (dl, (s, e)) =
123            case split_dl dl of
124      and c_strb (ast, accum) =              (s', []) => (SS.union (s', s), e)
125          case ast of            | (s', dl') => let
126              Strb { name, def, constraint } =>                  val dl'' = if SS.isEmpty s then dl'
127                  {                             else rev (dl_addS (s, rev dl'))
                  name = name,  
                  def = c_strexp def,  
                  constraint = sigexpConst constraint  
                 } :: accum  
           | MarkStrb (arg, _) => c_strb (arg, accum)  
   
     and c_fctb (ast, accum) =  
         case ast of  
             Fctb { name, def } =>  
                 { name = name, def = c_fctexp def } :: accum  
           | MarkFctb (arg, _) => c_fctb (arg, accum)  
   
     and c_sigb (ast, accum) =  
         case ast of  
             Sigb { name, def } =>  
                 {  
                  name = name,  
                  def = c_sigexp def,  
                  constraint = NONE  
                 } :: accum  
           | 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 = 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  
   
     and functorParams (symOpt, constraint) = let  
         val c = c_sigexp constraint  
     in  
         case symOpt of  
             NONE => (NONE,c)  
           | SOME sym => (SOME sym, c)  
     end  
   
     and sigexpConst sec =  
         case sec of  
             NoSig => NONE  
           | Transparent sigexp => SOME (c_sigexp sigexp)  
           | Opaque sigexp => SOME (c_sigexp sigexp)  
   
     and c_sigexp ast =  
         case ast of  
             VarSig symbol => VarStrExp (symbolModPath [symbol])  
           | AugSig (se, whspecs) => let  
                 fun f (WhType (_, _, ty), x) = c_ty (ty, x)  
                   | f (WhStruct (_, head :: _), x) =  
                     SS.add (x, head)  
                   | f _ = raise Fail "decl/convert/c_sigexp"  
             in  
                 AugStrExp (c_sigexp se, foldr f SS.empty whspecs)  
             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 = 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)  
                     }  
             in  
                 (StrDecl (map f arg)) :: accum  
             end  
           | TycSpec (arg, _) => let  
                 fun filter ((_, _, SOME x) :: rest) = x :: filter rest  
                   | filter (_ :: rest) = filter rest  
                   | filter nil = nil  
                 val mod'ref'set = foldr c_ty SS.empty (filter arg)  
             in  
                 modRefSet (mod'ref'set, accum)  
             end  
           | FctSpec arg => let  
                 fun f (symbol, fsigexp) =  
                     { name = symbol, def = c_fsigexp fsigexp }  
             in  
                 (FctDecl (map f arg)) :: accum  
             end  
           | ValSpec arg => let  
                 val mod'ref'set = foldr c_ty SS.empty (map #2 arg)  
             in  
                 modRefSet (mod'ref'set, accum)  
             end  
           | DataSpec { datatycs, withtycs } =>  
                 modRefSet (foldr c_db (foldr c_tb SS.empty withtycs) datatycs,  
                            accum)  
           | ExceSpec arg => let  
                 val mod'ref'set = foldr tyoption SS.empty (map #2 arg)  
             in  
                 modRefSet (mod'ref'set, accum)  
             end  
           | ShareStrSpec arg => foldr declRef accum arg  
           | ShareTycSpec arg => foldr declRef accum (map dropLast arg)  
           | IncludeSpec sigexp => (OpenDecl [c_sigexp sigexp]) :: accum  
           | MarkSpec (arg, _) => c_spec (arg, accum)  
   
     and c_vb (ast, accum) =  
         case ast of  
             Vb { pat, exp, lazyp } =>  
                 modRefSet (c_pat (pat, SS.empty), c_exp (exp, accum))  
           | MarkVb (arg, _) => c_vb (arg, accum)  
   
     and c_rvb (ast, accum) =  
         case ast of  
             Rvb { var, exp, resultty,... } =>  
                 modRefSet (tyoption (resultty, SS.empty), c_exp (exp, accum))  
           | MarkRvb (arg, _) => c_rvb (arg, accum)  
   
     and c_fb (ast, accum) =  
         case ast of  
             Fb (clauses, _) => foldr c_clause accum clauses  
           | MarkFb (arg,_) => c_fb (arg, accum)  
   
     and c_clause (Clause { pats, resultty, exp }, accum) =  
         modRefSet  
           (foldr c_pat (tyoption (resultty, SS.empty)) (map #item pats),  
            c_exp (exp, accum))  
   
     and c_tb (ast, accum) =  
         case ast of  
             Tb { tyc, def, tyvars } => c_ty (def, accum)  
           | MarkTb (arg, _) => c_tb (arg, accum)  
   
     and c_db (ast, accum) =  
         case ast of  
             Db { tyc, tyvars, rhs, lazyp } => c_dbrhs (rhs, accum)  
           | MarkDb (arg, _) => c_db (arg, accum)  
   
     and c_dbrhs (ast,accum) =  
         case ast of  
             Constrs def => foldr tyoption accum (map #2 def)  
           | Repl consName => modRef (consName, accum)  
   
     and c_eb (ast, accum) =  
         case ast of  
             EbGen { exn, etype } => tyoption (etype, accum)  
           | EbDef { exn, edef } => modRef (edef, accum)  
           | MarkEb (arg, _) => c_eb (arg, accum)  
   
     and c_exp (ast, accum) =  
         case ast of  
             VarExp path =>  
                 (case path of  
                      [] => accum  
                    | [only] => accum  
                    | head :: _ =>  
                          (case accum of  
                               [] => [DeclRef (SS.singleton head)]  
                             | (DeclRef otherRefs) :: tail =>  
                                   (DeclRef (SS.add (otherRefs, head))) :: tail  
                             | _ => (DeclRef (SS.singleton head)) :: accum))  
           | FnExp arg => foldr c_rule accum arg  
           | FlatAppExp items => foldr c_exp accum (map #item items)  
           | AppExp { function, argument } =>  
                 c_exp (function, c_exp (argument, accum))  
           | CaseExp {expr, rules } =>  
                 c_exp (expr, foldr c_rule accum rules)  
           | LetExp { dec, expr } =>  
                 (* syntactically only ldecs; no module scoping here *)  
                 localDec ((do_dec (dec, []), c_exp (expr, [])), accum)  
           | SeqExp arg => foldr c_exp accum arg  
           | RecordExp arg  => foldr c_exp accum (map #2 arg)  
           | ListExp arg => foldr c_exp accum arg  
           | TupleExp arg => foldr c_exp accum arg  
           | SelectorExp symbol => accum  
           | ConstraintExp { expr, constraint } =>  
                 c_exp (expr, modRefSet (c_ty (constraint, SS.empty), accum))  
           | HandleExp { expr, rules } =>  
                 c_exp (expr, foldr c_rule accum rules)  
           | RaiseExp expr => c_exp (expr, accum)  
           | IfExp { test, thenCase, elseCase } =>  
                 c_exp (test, c_exp (thenCase, c_exp (elseCase, accum)))  
           | AndalsoExp (expr1, expr2) => c_exp (expr1, c_exp (expr2, accum))  
           | OrelseExp (expr1, expr2) => c_exp (expr1, c_exp (expr2, accum))  
           | WhileExp { test, expr } => c_exp (test, c_exp (expr, accum))  
           | MarkExp (arg, _) => c_exp (arg, accum)  
           | VectorExp arg => foldr c_exp accum arg  
           | _ => accum  
   
     and c_rule (Rule { pat, exp }, accum) =  
         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)  
   
     fun check_toplevel (ast, err) = let  
         fun check_topl (StrDec _, _) = ()  
           | check_topl (AbsDec _, _) = ()  
           | check_topl (FctDec _, _) = ()  
           | check_topl (SigDec _, _) = ()  
           | check_topl (FsigDec _, _) = ()  
           | check_topl (LocalDec (_, body), reg) = check_topl (body, reg)  
           | check_topl (SeqDec arg, reg) =  
             app (fn ast => check_topl (ast, reg)) arg  
           | check_topl (OpenDec _, reg) = err EM.COMPLAIN reg "toplevel open"  
           | check_topl (MarkDec (arg, reg), _) = check_topl (arg, reg)  
           | check_topl (_, reg) =  
             err EM.WARN reg "definition not tracked by CM"  
128      in      in
129          check_topl (ast, (0, 0))                  (s', Let (dl'', e))
130      end      end
131    
132      fun convert { tree, err } = (check_toplevel (tree, err); c_dec tree)      (* making an Ign1 where necessary ... *)
133        fun ign (p1, NONE) = p1
134          | ign ((s1, e1), SOME (s2, e2)) = (SS.union (s1, s2), Ign1 (e1, e2))
135    
136        (* Open cancels Decl *)
137        fun open' (Decl dl, dl') = join_dl (dl, dl')
138          | open' (e, dl) = Open e :: dl
139    
140        (* generate a set of "parallel" bindings *)
141        fun parbind f l d = let
142            val (s, bl) = foldl f (SS.empty, []) l
143        in
144            dl_addS (s, parbindcons (bl, d))
145        end
146    
147        (* get the ref set from a type *)
148        fun ty_s (VarTy _, set) = set
149          | ty_s (ConTy (cn, l), set) = s_addMP (cn, foldl ty_s set l)
150          | ty_s (RecordTy l, set) = foldl (ty_s o' #2) set l
151          | ty_s (TupleTy l, set) = foldl ty_s set l
152          | ty_s (MarkTy (arg, _), set) = ty_s (arg, set)
153    
154        (* ... from a type option *)
155        fun tyopt_s (NONE, set) = set
156          | tyopt_s (SOME t, set) = ty_s (t, set)
157    
158        (* ... from a pattern *)
159        fun pat_s (VarPat p, set) = s_addMP (p, set)
160          | pat_s (RecordPat { def, ... }, set) = foldl (pat_s o' #2) set def
161          | pat_s ((ListPat l | TuplePat l | VectorPat l | OrPat l), set) =
162            foldl pat_s set l
163          | pat_s (FlatAppPat l, set) = foldl (pat_s o' #item) set l
164          | pat_s (AppPat { constr, argument }, set) =
165            pat_s (constr, pat_s (argument, set))
166          | pat_s (ConstraintPat { pattern, constraint }, set) =
167            pat_s (pattern, ty_s (constraint, set))
168          | pat_s (LayeredPat { varPat, expPat }, set) =
169            pat_s (varPat, pat_s (expPat, set))
170          | pat_s (MarkPat (arg, _), set) = pat_s (arg, set)
171          | pat_s ((WildPat|IntPat _|WordPat _|StringPat _|CharPat _), set) = set
172    
173        (* ... from an exception binding *)
174        fun eb_s (EbGen { exn, etype }, set) = tyopt_s (etype, set)
175          | eb_s (EbDef { exn, edef }, set) = s_addMP (edef, set)
176          | eb_s (MarkEb (arg, _), set) = eb_s (arg, set)
177    
178        (* ... *)
179        fun dbrhs_s (Constrs l, set) = foldl (tyopt_s o' #2) set l
180          | dbrhs_s (Repl cn, set) = s_addMP (cn, set)
181    
182        fun db_s (Db { tyc, tyvars, rhs, lazyp }, set) = dbrhs_s (rhs, set)
183          | db_s (MarkDb (arg, _), set) = db_s (arg, set)
184    
185        fun tb_s (Tb { tyc, def, tyvars }, set) = ty_s (def, set)
186          | tb_s (MarkTb (arg, _), set) = tb_s (arg, set)
187    
188        (* get a dl from an expression... *)
189        fun exp_dl (VarExp p, d) = dl_addMP (p, d)
190          | exp_dl (FnExp rl, d) = foldr rule_dl d rl
191          | exp_dl (FlatAppExp l, d) = foldr (exp_dl o' #item) d l
192          | exp_dl (AppExp { function, argument }, d) =
193            exp_dl (function, exp_dl (argument, d))
194          | exp_dl (CaseExp { expr, rules }, d) =
195            exp_dl (expr, foldr rule_dl d rules)
196          | exp_dl (LetExp { dec, expr }, d) =
197            local_dl (dec_dl (dec, []), exp_dl (expr, []), d)
198          | exp_dl ((SeqExp l | ListExp l | TupleExp l | VectorExp l), d) =
199            foldl exp_dl d l
200          | exp_dl (RecordExp l, d) = foldl (exp_dl o' #2) d l
201          | exp_dl (SelectorExp _, d) = d
202          | exp_dl (ConstraintExp { expr, constraint }, d) =
203            dl_addS (ty_s (constraint, SS.empty), exp_dl (expr, d))
204          | exp_dl (HandleExp { expr, rules }, d) =
205            exp_dl (expr, foldl rule_dl d rules)
206          | exp_dl (RaiseExp e, d) = exp_dl (e, d)
207          | exp_dl (IfExp { test, thenCase, elseCase }, d) =
208            exp_dl (test, exp_dl (thenCase, exp_dl (elseCase, d)))
209          | exp_dl ((AndalsoExp (e1, e2) | OrelseExp (e1, e2)), d) =
210            exp_dl (e1, exp_dl (e2, d))
211          | exp_dl (WhileExp { test, expr }, d) = exp_dl (test, exp_dl (expr, d))
212          | exp_dl (MarkExp (arg, _), d) = exp_dl (arg, d)
213          | exp_dl ((IntExp _|WordExp _|RealExp _|StringExp _|CharExp _), d) = d
214    
215        and rule_dl (Rule { pat, exp }, d) =
216            dl_addS (pat_s (pat, SS.empty), exp_dl (exp, d))
217    
218        and clause_dl (Clause { pats = p, resultty = t, exp = e }, d) =
219            dl_addS (foldl (pat_s o' #item) (tyopt_s (t, SS.empty)) p,
220                    exp_dl (e, d))
221    
222        and fb_dl (Fb (l, _), d) = foldr clause_dl d l
223          | fb_dl (MarkFb (arg, _), d) = fb_dl (arg, d)
224    
225        and vb_dl (Vb { pat, exp, lazyp }, d) =
226            dl_addS (pat_s (pat, SS.empty), exp_dl (exp, d))
227          | vb_dl (MarkVb (arg, _), d) = vb_dl (arg, d)
228    
229        and rvb_dl (Rvb { var, exp, resultty, ... }, d) =
230            dl_addS (tyopt_s (resultty, SS.empty), exp_dl (exp, d))
231          | rvb_dl (MarkRvb (arg, _), d) = rvb_dl (arg, d)
232    
233        and spec_dl (MarkSpec (arg, _), d) = spec_dl (arg, d)
234          | spec_dl (StrSpec l, d) = let
235                (* strange case - optional: structure, mandatory: signature *)
236                fun one ((n, g, c), (s, bl)) = let
237                    val (s', e) = sigexp_p g
238                    val s'' = SS.union (s, s')
239                in
240                    case c of
241                        NONE => (s'', (n, e) :: bl)
242                      | SOME p => (s'', (n, Ign1 (Var (SP.SPATH p), e)) :: bl)
243                end
244                val (s, bl) = foldr one (SS.empty, []) l
245            in
246                dl_addS (s, parbindcons (bl, d))
247            end
248          | spec_dl (TycSpec (l, _), d) = let
249                fun one_s ((_, _, SOME t), s) = ty_s (t, s)
250                  | one_s (_, s) = s
251            in
252                dl_addS (foldl one_s SS.empty l, d)
253            end
254          | spec_dl (FctSpec l, d) = let
255                fun one ((n, g), (s, bl)) = let
256                    val (s', e) = fsigexp_p g
257                in
258                    (SS.union (s, s'), (n, e) :: bl)
259                end
260                val (s, bl) = foldr one (SS.empty, []) l
261            in
262                dl_addS (s, parbindcons (bl, d))
263            end
264          | spec_dl (ValSpec l, d) = dl_addS (foldl (ty_s o' #2) SS.empty l, d)
265          | spec_dl (DataSpec { datatycs, withtycs }, d) =
266            dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) datatycs, d)
267          | spec_dl (ExceSpec l, d) = dl_addS (foldl (tyopt_s o' #2) SS.empty l, d)
268          | spec_dl (ShareStrSpec l, d) = foldl dl_addP d l
269          | spec_dl (ShareTycSpec l, d) = dl_addS (foldl s_addMP SS.empty l, d)
270          | spec_dl (IncludeSpec g, d) = let
271                val (s, e) = sigexp_p g
272            in
273                dl_addS (s, open' (e, d))
274            end
275    
276        and sigexp_p (VarSig s) = (SS.empty, Var (SP.SPATH [s]))
277          | sigexp_p (AugSig (g, whspecs)) = let
278                fun one_s (WhType (_, _, ty), s) = ty_s (ty, s)
279                  | one_s (WhStruct (_, p), s) = s_addP (p, s)
280                val (s, e) = sigexp_p g
281            in
282                (foldl one_s s whspecs, e)
283            end
284          | sigexp_p (BaseSig l) = let
285                val (s, d) = split_dl (foldr spec_dl [] l)
286            in
287                (s, Decl d)
288            end
289          | sigexp_p (MarkSig (arg, _)) = sigexp_p arg
290    
291        and fsigexp_p (VarFsig s) = (SS.empty, Var (SP.SPATH [s]))
292          | fsigexp_p (BaseFsig { param, result }) =
293            letexp (foldr fparam_d [] param, sigexp_p result)
294          | fsigexp_p (MarkFsig (arg, _)) = fsigexp_p arg
295    
296        and fparam_d ((nopt, g), d) = let
297            val (s, e) = sigexp_p g
298        in
299            case nopt of
300                NONE => dl_addS (s, open' (e, d))
301              | SOME n => dl_addS (s, Bind (n, e) :: d)
302        end
303    
304        and sigexpc_p NoSig = NONE
305          | sigexpc_p (Transparent g | Opaque g) = SOME (sigexp_p g)
306    
307        and fsigexpc_p NoSig = NONE
308          | fsigexpc_p (Transparent fg | Opaque fg) = SOME (fsigexp_p fg)
309    
310        and fctexp_p (VarFct (p, c)) =
311            ign ((SS.empty, Var (SP.SPATH p)), fsigexpc_p c)
312          | fctexp_p (BaseFct { params, body, constraint }) =
313            letexp (foldr fparam_d [] params,
314                    ign (strexp_p body, sigexpc_p constraint))
315          | fctexp_p (AppFct (p, l, c)) = let
316                fun one ((str, _), (s, el)) = let
317                    val (s', e) = strexp_p str
318                in
319                    (SS.union (s, s'), e :: el)
320                end
321                val (s, el) = foldl one (SS.empty, []) l
322                val (s', e) = ign ((SS.empty, Var (SP.SPATH p)), fsigexpc_p c)
323            in
324                (SS.union (s, s'), foldl Ign1 e el)
325            end
326          | fctexp_p (LetFct (bdg, b)) = letexp (dec_dl (bdg, []), fctexp_p b)
327          | fctexp_p (MarkFct (arg, _)) = fctexp_p arg
328    
329        and strexp_p (VarStr p) = (SS.empty, Var (SP.SPATH p))
330          | strexp_p (BaseStr dec) = let
331                val (s, dl) = split_dl (dec_dl (dec, []))
332            in
333                (s, Decl dl)
334            end
335          | strexp_p (ConstrainedStr (s, c)) = ign (strexp_p s, sigexpc_p c)
336          | strexp_p (AppStr (p, l) | AppStrI (p, l)) = let
337                fun one ((str, _), (s, el)) = let
338                    val (s', e) = strexp_p str
339                in
340                    (SS.union (s, s'), e :: el)
341                end
342                val (s, el) = foldl one (SS.empty, []) l
343            in
344                (s, foldl Ign1 (Var (SP.SPATH p)) el)
345            end
346          | strexp_p (LetStr (bdg, b)) = letexp (dec_dl (bdg, []), strexp_p b)
347          | strexp_p (MarkStr (s, _)) = strexp_p s
348    
349        and dec_dl (ValDec (l, _), d) = foldl vb_dl d l
350          | dec_dl (ValrecDec (l, _), d) = foldl rvb_dl d l
351          | dec_dl (FunDec (l, _), d) = foldl fb_dl d l
352          | dec_dl (TypeDec l, d) = dl_addS (foldl tb_s SS.empty l, d)
353          | dec_dl (DatatypeDec { datatycs, withtycs }, d) =
354            dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) datatycs, d)
355          | dec_dl (AbstypeDec { abstycs, withtycs, body }, d) =
356            dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) abstycs,
357                     dec_dl (body, d))
358          | dec_dl (ExceptionDec l, d) = dl_addS (foldl eb_s SS.empty l, d)
359          | dec_dl ((StrDec l | AbsDec l), d) = let
360                fun one (MarkStrb (arg, _), x) = one (arg, x)
361                  | one (Strb { name, def, constraint }, (s, bl)) = let
362                        val (s', e) = ign (strexp_p def, sigexpc_p constraint)
363                    in
364                        (SS.union (s, s'), (name, e) :: bl)
365                    end
366            in
367                parbind one l d
368            end
369          | dec_dl (FctDec l, d) = let
370                fun one (MarkFctb (arg, _), x) = one (arg, x)
371                  | one (Fctb { name, def }, (s, bl)) = let
372                        val (s', e) = fctexp_p def
373                    in
374                        (SS.union (s, s'), (name, e) :: bl)
375                    end
376            in
377                parbind one l d
378            end
379          | dec_dl (SigDec l, d) = let
380                fun one (MarkSigb (arg, _), x) = one (arg, x)
381                  | one (Sigb { name, def }, (s, bl)) = let
382                        val (s', e) = sigexp_p def
383                    in
384                        (SS.union (s, s'), (name, e) :: bl)
385                    end
386            in
387                parbind one l d
388            end
389          | dec_dl (FsigDec l, d) = let
390                fun one (MarkFsigb (arg, _), x) = one (arg, x)
391                  | one (Fsigb { name, def }, (s, bl)) = let
392                        val (s', e) = fsigexp_p def
393                    in
394                        (SS.union (s, s'), (name, e) :: bl)
395                    end
396            in
397                parbind one l d
398            end
399          | dec_dl (LocalDec (bdg, body), d) =
400            local_dl (dec_dl (bdg, []), dec_dl (body, []), d)
401          | dec_dl (SeqDec l, d) = foldr dec_dl d l
402          | dec_dl (OpenDec l, d) = parcons (map (Open o Var o SP.SPATH) l, d)
403          | dec_dl ((OvldDec _ | FixDec _), d) = d
404          | dec_dl (MarkDec (arg, _), d) = dec_dl (arg, d)
405    
406        fun c_dec d = seq (dec_dl (d, []))
407    
408        fun convert { tree, err } = let
409            (* build a function that will complain (once you call it)
410             * about any existing restriction violations *)
411            fun complainCM reg = let
412                fun sameReg (LocalDec (_, body), k) = sameReg (body, k)
413                  | sameReg (SeqDec l, k) = foldl sameReg k l
414                  | sameReg (OpenDec _, k) =
415                    (fn () => (k (); err EM.COMPLAIN reg "toplevel open"))
416                  | sameReg (MarkDec (arg, reg), k) = complainCM reg (arg, k)
417                  | sameReg ((StrDec _ | AbsDec _ | FctDec _ | SigDec _ |
418                              FsigDec _), k) = k
419                  | sameReg (_, k) =
420                    (fn () =>
421                     (k (); err EM.WARN reg "definition not tracked by CM"))
422    
423            in
424                sameReg
425            end
426    
427            fun warn0 () = ()
428            val complain = complainCM (0, 0) (tree, warn0)
429        in
430            { complain = complain, skeleton = c_dec tree }
431        end
432  end  end

Legend:
Removed from v.629  
changed lines
  Added in v.630

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