Mercurial > urweb

comparison src/fuse.sml @ 1018:9304474170ed

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Extend Fuse to work on non-recursive functions
author Adam Chlipala <adamc@hcoop.net>
date Sun, 25 Oct 2009 13:02:13 -0400
parents 3f3b211f9bca
children c1e3805e604e
comparison
equal deleted inserted replaced
1017:34ba25d6af3b 1018:9304474170ed
53 53
54 fun fuse file = 54 fun fuse file =
55 let 55 let
56 fun doDecl (d as (_, loc), (funcs, maxName)) = 56 fun doDecl (d as (_, loc), (funcs, maxName)) =
57 let 57 let
58 exception GetBody
59
60 fun doVi ((x, n, t, e, s), funcs, maxName) =
61 case returnsString t of
62 NONE => (NONE, funcs, maxName)
63 | SOME (args, t') =>
64 let
65 fun getBody (e, args) =
66 case (#1 e, args) of
67 (_, []) => (e, [])
68 | (EAbs (x, t, _, e), _ :: args) =>
69 let
70 val (body, args') = getBody (e, args)
71 in
72 (body, (x, t) :: args')
73 end
74 | _ => raise GetBody
75
76 val (body, args) = getBody (e, args)
77 val body = MonoOpt.optExp (EWrite body, loc)
78 val (body, _) = foldr (fn ((x, dom), (body, ran)) =>
79 ((EAbs (x, dom, ran, body), loc),
80 (TFun (dom, ran), loc)))
81 (body, (TRecord [], loc)) args
82 in
83 (SOME (x, maxName, t', body, s),
84 IM.insert (funcs, n, maxName),
85 maxName + 1)
86 end
87 handle GetBody => (NONE, funcs, maxName)
88
58 val (d, funcs, maxName) = 89 val (d, funcs, maxName) =
59 case #1 d of 90 case #1 d of
60 DValRec vis => 91 DVal vi =>
92 let
93 val (vi', funcs, maxName) = doVi (vi, funcs, maxName)
94 in
95 (case vi' of
96 NONE => d
97 | SOME vi' => (DValRec [vi, vi'], loc),
98 funcs, maxName)
99 end
100 | DValRec vis =>
61 let 101 let
62 val (vis', funcs, maxName) = 102 val (vis', funcs, maxName) =
63 foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) => 103 foldl (fn (vi, (vis', funcs, maxName)) =>
64 case returnsString t of 104 let
65 NONE => (vis', funcs, maxName) 105 val (vi', funcs, maxName) = doVi (vi, funcs, maxName)
66 | SOME (args, t') => 106 in
67 let 107 (case vi' of
68 fun getBody (e, args) = 108 NONE => vis'
69 case (#1 e, args) of 109 | SOME vi' => vi' :: vis',
70 (_, []) => (e, []) 110 funcs, maxName)
71 | (EAbs (x, t, _, e), _ :: args) => 111 end)
72 let
73 val (body, args') = getBody (e, args)
74 in
75 (body, (x, t) :: args')
76 end
77 | _ => raise Fail "Fuse: getBody"
78
79 val (body, args) = getBody (e, args)
80 val body = MonoOpt.optExp (EWrite body, loc)
81 val (body, _) = foldr (fn ((x, dom), (body, ran)) =>
82 ((EAbs (x, dom, ran, body), loc),
83 (TFun (dom, ran), loc)))
84 (body, (TRecord [], loc)) args
85 in
86 ((x, maxName, t', body, s) :: vis',
87 IM.insert (funcs, n, maxName),
88 maxName + 1)
89 end)
90 ([], funcs, maxName) vis 112 ([], funcs, maxName) vis
91 in 113 in
92 ((DValRec (vis @ vis'), loc), funcs, maxName) 114 ((DValRec (vis @ vis'), loc), funcs, maxName)
93 end 115 end
94 | _ => (d, funcs, maxName) 116 | _ => (d, funcs, maxName)