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

Parent Directory | Revision Log | Patch

	revision 285, Wed May 19 23:31:25 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

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

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

---

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