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 291, Mon May 24 09:41:07 1999 UTC revision 293, Tue May 25 03:04:50 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     *   Very heavily revised.
4   *   *
5   *   Copyright (c) 1999 by Lucent Technologies, Bell Laboratories   *   Copyright (c) 1999 by Lucent Technologies, Bell Laboratories
6   *   Copyright (c) 1995 by AT&T Bell Laboratories   *   Copyright (c) 1995 by AT&T Bell Laboratories
# Line 28  Line 29 
29      type symbol = Symbol.symbol      type symbol = Symbol.symbol
30      type path = symbol list      type path = symbol list
31    
32        (* function composition suitable for fold[lr]-arguments *)
33      infix o'      infix o'
34      fun (f o' g) (x, y) = f (g x, y)      fun (f o' g) (x, y) = f (g x, y)
35    
36      (* given a path, add an element to a set of module references *)      (* make a Seq node when necessary *)
37      (* here we always ignore the last component -- it is not supposed to      fun seq [] = Ref SS.empty
38       * be a module (we could actually check, but we know from context) *)        | seq [only] = only
39          | seq l = Seq l
40    
41        (* make a Par node when necessary and stick it in front of a given dl *)
42        fun par ([], d) = d
43          | par ([only], d) = only :: d
44          | par (l, d) = Par l :: d
45    
46        (* The main idea is to collect lists of decl ("dl"s).
47         * Normally, a dl will eventually become an argument to seq or par.
48         * As an important optimization, we always try to keep any "Ref s"
49         * at the front.  At the moment, however, we do not pay attention
50         * to whether a "Ref" commutes with a "Bind" and such.  In other words
51         * we are far from doing all conceivable optimizations. *)
52    
53        (* add the head of a symbol path to a given set *)
54        fun s_addP ([], set) = set
55          | s_addP (head :: _, set) = SS.add (set, head)
56    
57        (* same as s_addP except we ignore paths of length 1 because they
58         * do not involve module access. *)
59      fun s_addMP ([], set) = set         (* can this happen at all? *)      fun s_addMP ([], set) = set         (* can this happen at all? *)
60        | s_addMP ([only], set) = set     (* no module name here *)        | s_addMP ([only], set) = set     (* no module name here *)
61        | s_addMP (head :: _, set) = SS.add (set, head)        | s_addMP (head :: _, set) = SS.add (set, head)
# Line 54  Line 76 
76        | dl_addMP (head :: _, dl) = dl_addSym (head, dl)        | dl_addMP (head :: _, dl) = dl_addSym (head, dl)
77    
78      (* given a set of module references, add it to a decl list *)      (* given a set of module references, add it to a decl list *)
79      fun dl_addS (s, a) =      fun dl_addS (s, dl) =
80          if SS.isEmpty s then a          if SS.isEmpty s then dl
81          else case a of          else case dl of
82              [] => [Ref s]              [] => [Ref s]
83            | Ref s' :: a => Ref (SS.union (s, s')) :: a            | Ref s' :: dl' => Ref (SS.union (s, s')) :: dl'
84            | a => Ref s :: a            | _ => Ref s :: dl
85    
86      (* split initial ref set from a decl list *)      (* split initial ref set from a decl list *)
87      fun split_dl [] = (SS.empty, [])      fun split_dl [] = (SS.empty, [])
# Line 74  Line 96 
96      (* local definitions *)      (* local definitions *)
97      fun local_dl ([], b, d) = join_dl (b, d)      fun local_dl ([], b, d) = join_dl (b, d)
98        | local_dl (Ref s :: t, b, d) = dl_addS (s, local_dl (t, b, d))        | local_dl (Ref s :: t, b, d) = dl_addS (s, local_dl (t, b, d))
99        | local_dl (l, b, d) = Local (Seq l, Seq b) :: d        | local_dl (l, b, d) = Local (seq l, seq b) :: d
100    
101      (* build a let expression *)      (* build a let expression *)
102      fun letexp (dl, (s, e)) =      fun letexp (dl, (s, e)) =
# Line 84  Line 106 
106                  val dl'' = if SS.isEmpty s then dl'                  val dl'' = if SS.isEmpty s then dl'
107                             else rev (dl_addS (s, rev dl'))                             else rev (dl_addS (s, rev dl'))
108              in              in
109                  (s', Let (Seq dl'', e))                  (s', Let (dl'', e))
110              end              end
111    
112      (* making a Ign1 where necessary ... *)      (* making an Ign1 where necessary ... *)
113      fun ign (p1, NONE) = p1      fun ign (p1, NONE) = p1
114        | ign ((s1, e1), SOME (s2, e2)) = (SS.union (s1, s2), Ign1 (e1, e2))        | ign ((s1, e1), SOME (s2, e2)) = (SS.union (s1, s2), Ign1 (e1, e2))
115    
116        (* Open cancels Decl *)
117        fun open' (Decl dl, dl') = join_dl (dl, dl')
118          | open' (e, dl) = Open e :: dl
119    
120      (* generate a set of "parallel" bindings *)      (* generate a set of "parallel" bindings *)
121      fun parbind f l d = let      fun parbind f l d = let
122          val (s, bl) = foldl f (SS.empty, []) l          val (s, bl) = foldl f (SS.empty, []) l
123      in      in
124          dl_addS (s, Par bl :: d)          dl_addS (s, par (bl, d))
125      end      end
126    
127      (* get the ref set from a type *)      (* get the ref set from a type *)
# Line 186  Line 212 
212    
213      and spec_dl (MarkSpec (arg, _), d) = spec_dl (arg, d)      and spec_dl (MarkSpec (arg, _), d) = spec_dl (arg, d)
214        | spec_dl (StrSpec l, d) = let        | spec_dl (StrSpec l, d) = let
215              (* this is strange: signature is not optional! *)              (* strange case - optional: structure, mandatory: signature *)
216              fun one ((n, g, c), (s, bl)) = let              fun one ((n, g, c), (s, bl)) = let
217                  val (s', e) = sigexp_p g                  val (s', e) = sigexp_p g
218                  val s'' = SS.union (s, s')                  val s'' = SS.union (s, s')
# Line 197  Line 223 
223              end              end
224              val (s, bl) = foldr one (SS.empty, []) l              val (s, bl) = foldr one (SS.empty, []) l
225          in          in
226              dl_addS (s, Par bl :: d)              dl_addS (s, par (bl, d))
227          end          end
228        | spec_dl (TycSpec (l, _), d) = let        | spec_dl (TycSpec (l, _), d) = let
229              fun one_s ((_, _, SOME t), s) = ty_s (t, s)              fun one_s ((_, _, SOME t), s) = ty_s (t, s)
# Line 213  Line 239 
239              end              end
240              val (s, bl) = foldr one (SS.empty, []) l              val (s, bl) = foldr one (SS.empty, []) l
241          in          in
242              dl_addS (s, Par bl :: d)              dl_addS (s, par (bl, d))
243          end          end
244        | spec_dl (ValSpec l, d) = dl_addS (foldl (ty_s o' #2) SS.empty l, d)        | spec_dl (ValSpec l, d) = dl_addS (foldl (ty_s o' #2) SS.empty l, d)
245        | spec_dl (DataSpec { datatycs, withtycs }, d) =        | spec_dl (DataSpec { datatycs, withtycs }, d) =
# Line 224  Line 250 
250        | spec_dl (IncludeSpec g, d) = let        | spec_dl (IncludeSpec g, d) = let
251              val (s, e) = sigexp_p g              val (s, e) = sigexp_p g
252          in          in
253              dl_addS (s, Open e :: d)              dl_addS (s, open' (e, d))
254          end          end
255    
256      and sigexp_p (VarSig s) = (SS.empty, Var (SP.SPATH [s]))      and sigexp_p (VarSig s) = (SS.empty, Var (SP.SPATH [s]))
257        | sigexp_p (AugSig (g, whspecs)) = let        | sigexp_p (AugSig (g, whspecs)) = let
258              fun one_s (WhType (_, _, ty), s) = ty_s (ty, s)              fun one_s (WhType (_, _, ty), s) = ty_s (ty, s)
259                | one_s (WhStruct (_, head :: _), s) = SS.add (s, head)                | one_s (WhStruct (_, p), s) = s_addP (p, s)
               | one_s _ = raise Fail "skel-cvt/sigexp_p"  
260              val (s, e) = sigexp_p g              val (s, e) = sigexp_p g
261          in          in
262              (foldl one_s s whspecs, e)              (foldl one_s s whspecs, e)
# Line 239  Line 264 
264        | sigexp_p (BaseSig l) = let        | sigexp_p (BaseSig l) = let
265              val (s, d) = split_dl (foldr spec_dl [] l)              val (s, d) = split_dl (foldr spec_dl [] l)
266          in          in
267              (s, Decl (Seq d))              (s, Decl d)
268          end          end
269        | sigexp_p (MarkSig (arg, _)) = sigexp_p arg        | sigexp_p (MarkSig (arg, _)) = sigexp_p arg
270    
# Line 252  Line 277 
277          val (s, e) = sigexp_p g          val (s, e) = sigexp_p g
278      in      in
279          case nopt of          case nopt of
280              NONE => dl_addS (s, Open e :: d)              NONE => dl_addS (s, open' (e, d))
281            | SOME n => dl_addS (s, Bind (n, e) :: d)            | SOME n => dl_addS (s, Bind (n, e) :: d)
282      end      end
283    
# Line 285  Line 310 
310        | strexp_p (BaseStr dec) = let        | strexp_p (BaseStr dec) = let
311              val (s, dl) = split_dl (dec_dl (dec, []))              val (s, dl) = split_dl (dec_dl (dec, []))
312          in          in
313              (s, Decl (Seq dl))              (s, Decl dl)
314          end          end
315        | strexp_p (ConstrainedStr (s, c)) = ign (strexp_p s, sigexpc_p c)        | strexp_p (ConstrainedStr (s, c)) = ign (strexp_p s, sigexpc_p c)
316        | strexp_p (AppStr (p, l) | AppStrI (p, l)) = let        | strexp_p (AppStr (p, l) | AppStrI (p, l)) = let
# Line 354  Line 379 
379        | dec_dl (LocalDec (bdg, body), d) =        | dec_dl (LocalDec (bdg, body), d) =
380          local_dl (dec_dl (bdg, []), dec_dl (body, []), d)          local_dl (dec_dl (bdg, []), dec_dl (body, []), d)
381        | dec_dl (SeqDec l, d) = foldr dec_dl d l        | dec_dl (SeqDec l, d) = foldr dec_dl d l
382        | dec_dl (OpenDec l, d) = Par (map (Open o Var o SP.SPATH) l) :: d        | dec_dl (OpenDec l, d) = par (map (Open o Var o SP.SPATH) l, d)
383        | dec_dl ((OvldDec _ | FixDec _), d) = d        | dec_dl ((OvldDec _ | FixDec _), d) = d
384        | dec_dl (MarkDec (arg, _), d) = dec_dl (arg, d)        | dec_dl (MarkDec (arg, _), d) = dec_dl (arg, d)
385    
386      fun c_dec d = Seq (dec_dl (d, []))      fun c_dec d = seq (dec_dl (d, []))
387    
388      fun convert { tree, err } = let      fun convert { tree, err } = let
389          (* build a function that will complain (once you call it)          (* build a function that will complain (once you call it)
390           * about any existing restriction violations *)           * about any existing restriction violations *)
391          fun newReg reg = let          fun complainCM reg = let
392              fun sameReg (LocalDec (_, body), k) = sameReg (body, k)              fun sameReg (LocalDec (_, body), k) = sameReg (body, k)
393                | sameReg (SeqDec l, k) = foldl sameReg k l                | sameReg (SeqDec l, k) = foldl sameReg k l
394                | sameReg (OpenDec _, k) =                | sameReg (OpenDec _, k) =
395                  (fn () => (k (); err EM.COMPLAIN reg "toplevel open"))                  (fn () => (k (); err EM.COMPLAIN reg "toplevel open"))
396                | sameReg (MarkDec (arg, reg), k) = newReg reg (arg, k)                | sameReg (MarkDec (arg, reg), k) = complainCM reg (arg, k)
397                | sameReg ((StrDec _ | AbsDec _ | FctDec _ | SigDec _ |                | sameReg ((StrDec _ | AbsDec _ | FctDec _ | SigDec _ |
398                            FsigDec _), k) = k                            FsigDec _), k) = k
399                | sameReg (_, k) =                | sameReg (_, k) =
# Line 378  Line 403 
403          in          in
404              sameReg              sameReg
405          end          end
406    
407            fun warn0 () = ()
408            val complain = complainCM (0, 0) (tree, warn0)
409      in      in
410          { complain = newReg (0, 0) (tree, fn () => ()), skeleton = c_dec tree }          { complain = complain, skeleton = c_dec tree }
411      end      end
412  end  end

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

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