-(* Copyright 1999, 2004, 2007, 2010 Stefan Monnier <monnier@gnu.org> *)
+(* Copyright 1999,2004,2007,2010-2012 Stefan Monnier <monnier@gnu.org> *)
-(let val a = 1 val b = 2
- val c = 3
- in 1
- end);
-
-(* From "Christopher Dutchyn" <cdutchyn@cs.ubc.ca> *)
-(case foo of
- (* FIXME: The line gets unindented by 2 every time you hit TAB :-( *)
- | BAR => baz)
-
-(* sml-mode here treats the second `=' as an equal op because it assumes
- * that the first is the definitional equal for the structure. FIXME! *)
+(* sml-mode here treats the second `=' as an equal op because it
+ * thinks it's seeing something like "... type t = (s.t = ...)". FIXME! *)
functor foo (structure s : S) where type t = s.t =
-struct
-val bar = 0
+struct (* fixindent *)
+val bar = fn a1 a2 a3
+ a5 a6
+ a4 => 1
+val rec bar =
+ fn a1 a2 a3
+ a5 a6 a4 => 1
+val bar =
+ fn a1 a2 a3
+ a5 a6
+ a4 => (1
+ ;(
+ w
+ ,
+ s
+ ,
+ s
+ , s , a ,
+ a
+ , s , a ,
+ a
+ )
+ ;(
+ w
+ ,s
+ ,a
+ )
+ ;(
+ w
+ , s
+ , a
+ )
+ ;( w
+ , s
+ , a
+ )
+ ;( w
+ ,s
+ ,a
+ )
+ ;3
+ + a
+ * 4
+ + let val x = 3
+ in toto
+ end
+ + if a then
+ b
+ else
+ c
+ ;4)
+
val ber = 1;
val sdfg = 1
val tut = fn (x,y) z y e r =>
body
-end
+val tut = fn (x,y) => fn z y => fn e r =>
+ body
+val tut = fn (x,y)
+ z
+ y e
+ r =>
+ body
+val tut =
+ (let
+ local
+ val x = 1 in val x = x end
+ val a = 1 val b = 2
+ local val x = 1 in val x = x end
+ local val x = 1 in val x = x end
+ local val x = 1 in val x = x end (* fixindent *)
+ local val x = 1 in val x = x end
+ val c = 3
+ in
+ let
+ val x = 3
+ in
+ x + a * b
+ * c
+ end
+ end)
+
+val x =
+ (* From "Christopher Dutchyn" <cdutchyn@cs.ubc.ca> *)
+ (case foo of
+ (* This is actually not valid SML anyway. *)
+ | BAR => baz
+ | BAR => baz)
+
+val x =
+ (x := 1;
+ x := 2;
+ (* Testing obedience to user overrides: *)
+ x := 3; (* fixindent *)
+ case x of
+ FOO => 1
+ | BAR =>
+ 2;
+ case x of
+ FOO => 1
+ | BAR =>
+ case y of
+ FAR => 2
+ | FRA => 3;
+ hello);
-(x := 1;
- case x of
- FOO => 1
- | BAR =>
- 2;
- case x of
- FOO => 1
- | BAR =>
- (case y of
- FAR => 2
- | FRA => 3);
- hello);
-
-let datatype foobar
- = FooB of int
- | FooA of bool * int
- datatype foo = FOO | BAR of baz
- and baz = BAZ | QUUX of foo
-
- datatype foo = FOO
- | BAR of baz
- and baz = BAZ (* fixindent *)
- | QUUX of foo
- and b = g
-
- datatype foo = datatype M.foo
- val _ = 42 val x = 5
-
- signature S = S' where type foo = int
- val _ = 42
-
- val foo = [
- "blah"
- , let val x = f 42 in g (x,x,44) end
+datatype foobar
+ = FooB of int
+ | FooA of bool * int
+datatype foo = FOO | BAR of baz
+ and baz = BAZ | QUUX of foo
+
+fun toto = if a
+ then
+ b
+ else c
+
+datatype foo = FOO
+ | BAR of baz
+ and baz = BAZ (* fixindent *)
+ | QUUX of foo
+ and b = g
+
+datatype foo = datatype M.foo
+val _ = 42 val x = 5
+
+signature S = S' where type foo = int
+val _ = 42
+
+val foo = [
+ "blah"
+ , let val x = f 42 in g (x,x,44) end
+]
+
+val foo = [
+ "blah",
+ let val x = f 42 in g (x,x,44) end
+]
+
+val foo =
+ [
+ "blah",
+ let val x = f 42 in g (x,x,44) end
]
-
- val foo = [ "blah"
- , let val x = f 42 in g (x,x,44) end
- , foldl (fn ((p,q),s) => g (p,q,Vector.length q) ^ ":" ^ s)
- "" (Beeblebrox.masterCountList mlist2)
- , if null mlist2 then ";" else ""
- ]
-
- fun foo (true::rest)
- = 1 + 2 * foo rest
- | foo (false::rest)
- = let val _ = 1 in 2 end
- + 2 * foo rest
-
- val x = if foo then
- 1
- else if bar then
- 2
- else
- 3
- val y = if foo
- then 1
- else if foo
- then 2
- else 3
-
- ; val yt = 4
-in
- if a then b else c;
- case M.find(m,f)
- of SOME(fl, filt) =>
- F.APP(F.VAR fl, OU.filter filt vs)
- | NONE => le;
- x := x + 1;
- (case foo
- of a => f
- )
-end;
+val foo = [ "blah"
+ , let val x = f 42 in g (x,x,44) end
+ , foldl (fn ((p,q),s) => g (p,q,Vector.length q) ^ ":" ^ s)
+ "" (Beeblebrox.masterCountList mlist2)
+ , if null mlist2 then ";" else ""
+ ]
-let
-in a;
- foo("(*")
- * 2;
-end;
+fun foo (true::rest) = 1 + 2 * foo rest
+ | foo (false::rest)
+ = let val _ = 1 in 2 end
+ + 2
+ * foo rest
-let
-in a
- ; b
-end;
+val x = if foo then
+ 1
+ else if bar then
+ 2
+ else
+ 3
+val y = if foo
+ then 1
+ else if foo
+ then 2 (* Could also be indented by a basic offset. *)
+ else 3
-let
-in
- a
- ; b
-end;
+val yt = 4
-let
-in if a then
- b
- else
- c
-end;
+val x =
+ (if a then b else c;
+ case M.find(m,f)
+ of SOME(fl, filt) =>
+ F.APP(F.VAR fl, OU.filter filt vs)
+ | NONE
+ => le
+ | NONE =>
+ le
+ | NONE => le;
+ x := x + 1;
+ (case foo
+ of a => f
+ ))
-let
-in case a of
- F => 1
- | D => 2
-end;
+val y = (
+ let fun f1 =
+ let fun g1 x = 2
+ fun g2 y = 4
+ local fun toto y = 1
+ (* val x = 5 *)
+ in
+ fun g3 z = z
+ end
+ in toto
+ end
+ in a;( ( let
+ val f =1
+ in
+ toto
+ end
+ )
+ )
+ foo("(*")
+ * 2;
+ end;
-let
-in case a
- of F => 1
- | D => 2
-end;
+ let
+ in a
+ ; b
+ end;
+
+ let
+ in
+ a +
+ b +
+ c
+ ; b
+ end;
+
+ let
+ in if a then
+ b
+ else
+ c
+ end;
+
+ let
+ in case a of
+ F => 1
+ | D => 2
+ end;
-let
-in if a then b else
- c
+ let
+ in case a
+ of F => 1
+ | D => 2
+ end;
+
+ let
+ in if a then b else
+ c
+ end;
+
+ let
+ in if a then b
+ else
+ c
+ end)
end;
structure Foo = struct
val x = 1
end
+structure Foo = struct val x = 1
+ end
+
signature FSPLIT =
sig
type flint = FLINT.prog
fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
fun assert p = if p then () else bug ("assertion failed")
-
+
type flint = F.prog
val mklv = LambdaVar.mkLvar
val cplv = LambdaVar.dupLvar
-
+
fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
-
+
fun addv (s,F.VAR lv) = S.add(s, lv)
| addv (s,_) = s
fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv(l, s)) s lvs
-
+
exception Unknown
-
+
fun split (fdec as (fk,f,args,body)) = let
val {getLty,addLty,...} = Recover.recover (fdec, false)
-
+
val m = Intmap.new(64, Unknown)
fun addpurefun f = Intmap.add m (f, false)
fun funeffect f = (Intmap.map m f) handle Uknown => true
* mistakenly adding anything to leI.
*)
fun sexp env lexp = (* fixindent *)
- let
+ let
(* non-side effecting binds are copied to leI if exported *)
fun let1 (le,lewrap,lv,vs,effect) =
let val (leE,leI,fvI,leRet) = sexp (S.add(env, lv)) le
then (leE, leI, fvI, leRet)
else (leE, lewrap leI, addvs(S_rmv(lv, fvI), vs), leRet)
end
-
+
in case lexp
(* we can completely move both RET and TAPP to the I part *)
of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
(fn e => e, lexp, addvs(S.empty, vs), lexp)
| F.TAPP (F.VAR tf,tycs) =>
(fn e => e, lexp, S.singleton tf, lexp)
-
+
(* recursive splittable lexps *)
| F.FIX (fdecs,le) => sfix env (fdecs, le)
| F.TFN (tfdec,le) => stfn env (tfdec, le)
-
+
(* binding-lexps *)
| F.CON (dc,tycs,v,lv,le) =>
let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
| F.PRIMOP (po,vs,lv,le) =>
let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
-
+
(* IMPROVEME: lvs should not be restricted to [lv] *)
| F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
| F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
-
+
| F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
-
+
| F.LET (lvs,body,le) =>
let val (leE,leI,fvI,leRet) = sexp (S.union(S.addList(S.empty, lvs), env)) le
in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
end
-
+
(* useless sophistication *)
| F.APP (F.VAR f,args) =>
if funeffect f
then (fn e => e, F.RET[], S.empty, lexp)
else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
-
+
(* other non-binding lexps result in unsplittable functions *)
| (F.APP _ | F.TAPP _) => bug "strange (T)APP"
| (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
(fn e => e, F.RET[], S.empty, lexp)
end
-
+
(* Functions definitions fall into the following categories:
* - inlinable: if exported, copy to leI
* - (mutually) recursive: don't bother
end
| [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
sfdec env (leE,leI,fvI,leRet) fdec
-
+
| _ => (nleE, leI, fvI, leRet)
end
-
+
and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
let val benv = S.union(S.addList(S.empty, map #1 args), env)
val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
| _ =>
let val fvbIs = S.listItems(S.difference(fvbI, benv))
val (nfk,fkE) = OU.fk_wrap(fk, NONE)
-
+
(* fdecE *)
val fE = cplv f
val fErets = (map F.VAR fvbIs)
val fdecE = (fkE, fE, args, bodyE)
val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
val _ = addLty(fE, fElty)
-
+
(* fdecI *)
val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
known=true, isrec=NONE}
(map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
val _ = addpurefun fI
-
+
(* nfdec *)
val nargs = map (fn (v,t) => (cplv v, t)) args
val argsv = map (fn (v,t) => F.VAR v) nargs
F.APP(F.VAR fI, (F.VAR lv)::argsv))
end *)
val nfdec = (nfk, f, nargs, nbody)
-
+
(* and now, for the whole F.FIX *)
fun nleE e =
F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
-
+
in if not(S.member(fvI, f)) then (nleE, leI, fvI, leRet)
else (nleE,
F.FIX([fdecI], F.FIX([nfdec], leI)),
leRet)
end
end
-
+
(* TFNs are kinda like FIX except there's no recursion *)
and stfn env (tfdec as (tfk,tf,args,body),le) =
let val (bodyE,bodyI,fvbI,bodyRet) =
val bodyE = bodyE(F.RET tfEvs)
val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
val _ = addLty(tfE, tfElty)
-
+
(* tfdecI *)
val tfkI = {inline=F.IH_ALWAYS}
val argsI = map (fn (v,k) => (cplv v, k)) args
fun nleE e =
F.TFN((tfk, tfE, args, bodyE),
F.TFN((tfkI, tf, argsI, bodyI), leE e))
-
+
in if not(S.member(fvI, tf)) then (nleE, leI, fvI, leRet)
else (nleE,
F.TFN((tfkI, tf, argsI, bodyI), leI),
leRet)
end
end
-
+
(* here, we use B-decomposition, so the args should not be
* considered as being in scope *)
val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
| (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
let val fvbIs = S.listItems fvbI
-
+
(* fdecE *)
val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
-
+
(* fdecI *)
val argI = mklv()
val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
(n+1, F.SELECT(F.VAR argI, n, lv, le)))
(length vs, bodyI) fvbIs
val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
-
+
val nargs = map (fn (v,t) => (cplv v, t)) args
in
(fdecE, SOME fdecI)
F.APP(F.VAR fI, [F.VAR argI]))))),
NONE) *)
end
-
+
| _ => (fdec, NONE) (* sorry, can't do that *)
(* (PPFlint.printLexp bodyRet; bug "couldn't find the returned record") *)
-
+
end
-
+
end
end