diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2008-07-13 16:11:25 -0400 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2008-07-13 16:11:25 -0400 |
| commit | 97cc749872a8baf53bb34ef1b536b82f6aa7f1c7 (patch) | |
| tree | c297f92dea86916471d18bb3c987834935bfcce2 /src/tag.sml | |
| parent | f0b8905c1239b9b801c01cff28302cbd8d362f6e (diff) | |
Proper handling of non-function-call links
Diffstat (limited to 'src/tag.sml')
| -rw-r--r-- | src/tag.sml | 41 |
1 files changed, 28 insertions, 13 deletions
diff --git a/src/tag.sml b/src/tag.sml index 9004a55b..e451281a 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -171,20 +171,35 @@ fun tag file = val (fnam, t, _, tag) = E.lookupENamed env f val (args, result) = unravel t - val (app, _) = foldl (fn (t, (app, n)) => - ((EApp (app, (ERel n, loc)), loc), - n - 1)) - ((ENamed f, loc), length args - 1) args - val body = (EWrite app, loc) val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) - val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => - ((EAbs ("x" ^ Int.toString n, - t, - rest, - abs), loc), - n + 1, - (TFun (t, rest), loc))) - (body, 0, unit) args + + val (abs, t) = + case args of + [] => + let + val body = (EWrite (ENamed f, loc), loc) + in + ((EAbs ("x", unit, unit, body), loc), + (TFun (unit, unit), loc)) + end + | _ => + let + val (app, _) = foldl (fn (t, (app, n)) => + ((EApp (app, (ERel n, loc)), loc), + n - 1)) + ((ENamed f, loc), length args - 1) args + val body = (EWrite app, loc) + val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => + ((EAbs ("x" ^ Int.toString n, + t, + rest, + abs), loc), + n + 1, + (TFun (t, rest), loc))) + (body, 0, unit) args + in + (abs, t) + end in [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc), (DExport cn, loc)] |