[m-rev.] for review: finish dir.m implementation for erlang backend
Peter Wang
novalazy at gmail.com
Wed Sep 26 11:03:00 AEST 2007
Estimated hours taken: 6
Branches: main
Finish implementation of dir.m for Erlang backend.
library/dir.m:
Change the procedures in this module to thread `dir.stream' values
through them. In the Erlang backend a `dir.stream' is a list of file
names in a directory, rather than a handle, so an output argument is
needed when reading an entry from the stream.
Implement the missing foreign_procs for Erlang.
library/io.m:
Make the Erlang implementation of `io.file_type' support symlinks.
Implement `file_id' support for Erlang.
Fix the C implementation of compare on `file_id's, which did not take
into account file inodes at all.
Fix error handling in the Erlang implementation of
`io.make_symlink_2'.
tests/hard_coded/dir_test.exp2:
Update expected output for the fixed `file_id' comparison.
tests/hard_coded/dir_test.exp3:
Update expected output for a previous change (addition of
`dir.current_directory').
Index: library/dir.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/dir.m,v
retrieving revision 1.43
diff -u -r1.43 dir.m
--- library/dir.m 21 Sep 2007 03:21:35 -0000 1.43
+++ library/dir.m 26 Sep 2007 01:07:17 -0000
@@ -1214,14 +1214,14 @@
list(file_id)::in, bool::in, bool::in, bool::out, T::in,
io.maybe_partial_res(T)::out, io::di, io::uo) is det.
-:- pred dir.foldl2_process_dir2(dir.stream::in, bool::in,
+:- pred dir.foldl2_process_dir2(dir.stream::in, dir.stream::out, bool::in,
dir.foldl_pred(T)::in(dir.foldl_pred), string::in,
list(file_id)::in, string::in, bool::in, bool::in, T::in,
{io.maybe_partial_res(T), bool}::out, io::di, io::uo) is det.
-dir.foldl2_process_dir2(Dir, SymLinkParent, P, DirName, ParentIds, FirstEntry,
+dir.foldl2_process_dir2(!Dir, SymLinkParent, P, DirName, ParentIds, FirstEntry,
Recursive, FollowLinks, T0, {Res, Cont}, !IO) :-
- dir.foldl2_process_entries(Dir, SymLinkParent, P, DirName,
+ dir.foldl2_process_entries(!Dir, SymLinkParent, P, DirName,
ok(FirstEntry), ParentIds, Recursive, FollowLinks, Cont,
T0, Res, !IO).
@@ -1242,26 +1242,43 @@
LoopRes = ok(no),
dir.open(DirName, OpenResult, !IO),
(
- OpenResult = ok({Dir, FirstEntry}),
+ OpenResult = ok({Dir0, FirstEntry}),
% We need to close the directory if an
% exception is thrown to avoid resource leaks.
- Cleanup = dir.close(Dir),
- exception.finally(dir.foldl2_process_dir2(Dir, SymLinkParent,
- P, DirName, ParentIds, FirstEntry, Recursive, FollowLinks,
- T0), {DirRes, Continue}, Cleanup, CleanupRes, !IO),
+ ProcessDir =
+ (pred({DirRes1, Continue1, Dir1}::out,
+ IO0::di, IO::uo) is det :-
+ dir.foldl2_process_dir2(Dir0, Dir1, SymLinkParent,
+ P, DirName, ParentIds, FirstEntry, Recursive,
+ FollowLinks, T0, {DirRes1, Continue1}, IO0, IO)
+ ),
+ promise_equivalent_solutions [!:IO, ExcpResult] (
+ exception.try_io(ProcessDir, ExcpResult, !IO)
+ ),
(
- DirRes = ok(T),
+ ExcpResult = succeeded({DirRes, Continue, Dir}),
(
- CleanupRes = ok,
- Result = DirRes
+ DirRes = ok(T),
+ dir.close(Dir, CleanupRes, !IO),
+ (
+ CleanupRes = ok,
+ Result = ok(T)
+ ;
+ CleanupRes = error(Error),
+ Result = error(T, Error)
+ )
;
- CleanupRes = error(Error),
- Result = error(T, Error)
+ DirRes = error(_, _),
+ Result = DirRes
)
;
- DirRes = error(_, _),
- Result = DirRes
+ ExcpResult = exception(_),
+ % We are relying on the fact that in the C, IL and Java
+ % backends Dir0 = Dir, and in the Erlang backend dir.close
+ % does nothing.
+ dir.close(Dir0, _, !IO),
+ rethrow(ExcpResult)
)
;
OpenResult = eof,
@@ -1289,16 +1306,16 @@
"not implemented on this platform"))
).
-:- pred dir.foldl2_process_entries(dir.stream::in, bool::in,
+:- pred dir.foldl2_process_entries(dir.stream::in, dir.stream::out, bool::in,
dir.foldl_pred(T)::in(dir.foldl_pred), string::in,
io.result(string)::in, list(file_id)::in, bool::in,
bool::in, bool::out, T::in, io.maybe_partial_res(T)::out,
io::di, io::uo) is det.
-dir.foldl2_process_entries(_, _, _, _, error(Error), _, _, _, no,
+dir.foldl2_process_entries(!Dir, _, _, _, error(Error), _, _, _, no,
T0, error(T0, Error), !IO).
-dir.foldl2_process_entries(_, _, _, _, eof, _, _, _, yes, T0, ok(T0), !IO).
-dir.foldl2_process_entries(Dir, SymLinkParent, P, DirName, ok(FileName),
+dir.foldl2_process_entries(!Dir, _, _, _, eof, _, _, _, yes, T0, ok(T0), !IO).
+dir.foldl2_process_entries(!Dir, SymLinkParent, P, DirName, ok(FileName),
ParentIds, Recursive, FollowLinks, Continue, T0, Res, !IO) :-
PathName = DirName/FileName,
io.file_type(no, PathName, FileTypeRes, !IO),
@@ -1341,8 +1358,18 @@
Continue2 = yes,
Res1 = ok(T)
->
- dir.read_entry(Dir, EntryResult, !IO),
- dir.foldl2_process_entries(Dir, SymLinkParent, P, DirName,
+ dir.read_entry(!.Dir, EntryResult0, !IO),
+ (
+ EntryResult0 = ok({!:Dir, FileName1}),
+ EntryResult = ok(FileName1)
+ ;
+ EntryResult0 = eof,
+ EntryResult = eof
+ ;
+ EntryResult0 = error(Error),
+ EntryResult = error(Error)
+ ),
+ dir.foldl2_process_entries(!Dir, SymLinkParent, P, DirName,
EntryResult, ParentIds, Recursive, FollowLinks, Continue,
T, Res, !IO)
;
@@ -1429,6 +1456,7 @@
:- pragma foreign_type("il", dir.stream,
"class [mscorlib]System.Collections.IEnumerator").
:- pragma foreign_type("Java", dir.stream, "java.util.Iterator").
+:- pragma foreign_type("Erlang", dir.stream, "").
:- pred can_implement_dir_foldl is semidet.
@@ -1452,6 +1480,11 @@
[will_not_call_mercury, promise_pure, thread_safe],
"SUCCESS_INDICATOR = true;"
).
+:- pragma foreign_proc("Erlang",
+ can_implement_dir_foldl,
+ [will_not_call_mercury, promise_pure, thread_safe],
+ "SUCCESS_INDICATOR = true"
+).
% Win32 doesn't allow us to open a directory without
% returning the first item.
@@ -1543,12 +1576,24 @@
}
").
+:- pragma foreign_proc("Erlang",
+ dir.open_2(DirName::in, Result::out, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates],
+"
+ DirNameStr = binary_to_list(DirName),
+ case file:list_dir(DirNameStr) of
+ {ok, FileNames0} ->
+ FileNames = lists:sort(FileNames0),
+ Result = mercury__dir:'ML_dir_read_first_entry'(FileNames);
+ {error, Reason} ->
+ Result = mercury__dir:'ML_make_dir_open_result_error'(Reason)
+ end
+").
+
:- pred dir.check_dir_readable(string::in, int::out,
io.result({dir.stream, string})::out, io::di, io::uo) is det.
:- pragma foreign_export("C", dir.check_dir_readable(in, out, out, di, uo),
"ML_check_dir_readable").
-:- pragma foreign_export("IL", dir.check_dir_readable(in, out, out, di, uo),
- "ML_check_dir_readable").
dir.check_dir_readable(DirName, IsReadable, Result, !IO) :-
io.file_type(yes, DirName, FileTypeRes, !IO),
@@ -1585,19 +1630,11 @@
"ML_dir_read_first_entry").
:- pragma foreign_export("IL", dir.read_first_entry(in, out, di, uo),
"ML_dir_read_first_entry").
+:- pragma foreign_export("Erlang", dir.read_first_entry(in, out, di, uo),
+ "ML_dir_read_first_entry").
dir.read_first_entry(Dir, Result, !IO) :-
- dir.read_entry(Dir, EntryResult, !IO),
- (
- EntryResult = ok(FirstEntry),
- Result = ok({Dir, FirstEntry})
- ;
- EntryResult = eof,
- Result = eof
- ;
- EntryResult = error(Msg),
- Result = error(Msg)
- ).
+ dir.read_entry(Dir, Result, !IO).
:- pred make_win32_dir_open_result_ok(dir.stream::in, c_pointer::in,
io.result({dir.stream, string})::out, io::di, io::uo) is det.
@@ -1615,8 +1652,8 @@
->
dir.read_entry(Dir, ReadResult, !IO),
(
- ReadResult = ok(FirstFile),
- Result = ok({Dir, FirstFile})
+ ReadResult = ok(_),
+ Result = ReadResult
;
ReadResult = eof,
dir.close(Dir, CloseRes, !IO),
@@ -1667,6 +1704,8 @@
"ML_make_dir_open_result_error").
:- pragma foreign_export("IL", make_dir_open_result_error(in, out, di, uo),
"ML_make_dir_open_result_error").
+:- pragma foreign_export("Erlang", make_dir_open_result_error(in, out, di, uo),
+ "ML_make_dir_open_result_error").
make_dir_open_result_error(Error, error(io.make_io_error(Msg)), !IO) :-
io.make_err_msg(Error, "dir.foldl2: opening directory failed: ", Msg, !IO).
@@ -1721,11 +1760,20 @@
Status = 1;
}").
-:- pred dir.read_entry(dir.stream::in, io.result(string)::out,
+:- pragma foreign_proc("Erlang",
+ dir.close_2(_Dir::in, Status::out, Error::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
+ % Nothing to do.
+ Error = null,
+ Status = 1
+").
+
+:- pred dir.read_entry(dir.stream::in, io.result({dir.stream, string})::out,
io::di, io::uo) is det.
-dir.read_entry(Dir, Res, !IO) :-
- dir.read_entry_2(Dir, Status, Error, FileName, !IO),
+dir.read_entry(Dir0, Res, !IO) :-
+ dir.read_entry_2(Dir0, Dir, Status, Error, FileName, !IO),
(
Status = 0
->
@@ -1741,19 +1789,19 @@
; FileName = dir.parent_directory
)
->
- dir.read_entry(Dir, Res, !IO)
+ dir.read_entry(Dir0, Res, !IO)
;
- Res = ok(FileName)
+ Res = ok({Dir, FileName})
).
- % dir.read_entry_2(Dir, Status, Error, FileName, !IO).
+ % dir.read_entry_2(!Dir, Status, Error, FileName, !IO).
% Status is -1 for EOF, 0 for error, 1 for success.
%
-:- pred dir.read_entry_2(dir.stream::in, int::out, io.system_error::out,
- string::out, io::di, io::uo) is det.
+:- pred dir.read_entry_2(dir.stream::in, dir.stream::out, int::out,
+ io.system_error::out, string::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
- dir.read_entry_2(Dir::in, Status::out, Error::out, FileName::out,
+ dir.read_entry_2(Dir0::in, Dir::out, Status::out, Error::out, FileName::out,
IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, tabled_for_io, thread_safe,
will_not_modify_trail, does_not_affect_liveness],
@@ -1761,6 +1809,7 @@
#if defined(MR_WIN32)
WIN32_FIND_DATA file_data;
+ Dir = Dir0;
IO = IO0;
if (FindNextFile(Dir, &file_data)) {
Status = 1;
@@ -1774,6 +1823,7 @@
#elif defined(MR_HAVE_READDIR) && defined(MR_HAVE_CLOSEDIR)
struct dirent *dir_entry;
+ Dir = Dir0;
IO = IO0;
errno = 0;
dir_entry = readdir(Dir);
@@ -1793,10 +1843,11 @@
}").
:- pragma foreign_proc("C#",
- dir.read_entry_2(Dir::in, Status::out, Error::out, FileName::out,
- _IO0::di, _IO::uo),
+ dir.read_entry_2(Dir0::in, Dir::out, Status::out, Error::out,
+ FileName::out, _IO0::di, _IO::uo),
[will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
"{
+ Dir = Dir0;
try {
if (Dir.MoveNext()) {
// The .NET CLI returns path names qualified with
@@ -1816,10 +1867,11 @@
}").
:- pragma foreign_proc("Java",
- dir.read_entry_2(Dir::in, Status::out, Error::out, FileName::out,
- _IO0::di, _IO::uo),
+ dir.read_entry_2(Dir0::in, Dir::out, Status::out, Error::out,
+ FileName::out, _IO0::di, _IO::uo),
[will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
"
+ Dir = Dir0;
if (Dir.hasNext()) {
FileName = (java.lang.String) Dir.next();
Status = 1;
@@ -1830,6 +1882,23 @@
Error = null;
").
+:- pragma foreign_proc("Erlang",
+ dir.read_entry_2(Dir0::in, Dir::out, Status::out, Error::out,
+ FileName::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
+ case Dir0 of
+ [] ->
+ FileName = null,
+ Status = -1,
+ Dir = [];
+ [FileNameStr | Dir] ->
+ FileName = list_to_binary(FileNameStr),
+ Status = 1
+ end,
+ Error = null
+").
+
%-----------------------------------------------------------------------------%
expand_braces(ArgStr) = ExpandStrs :-
Index: library/io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.403
diff -u -r1.403 io.m
--- library/io.m 21 Sep 2007 03:21:35 -0000 1.403
+++ library/io.m 26 Sep 2007 01:07:17 -0000
@@ -1373,6 +1373,7 @@
% in `AccessTypes' on `FileName'.
% XXX When using the .NET CLI, this predicate will sometimes report
% that a directory is writable when in fact it is not.
+ % XXX When using the Erlang backend, `execute' access is not checked.
%
:- pred io.check_file_accessibility(string::in, list(access_type)::in,
io.res::out, io::di, io::uo) is det.
@@ -3144,6 +3145,9 @@
regular ->
Result = mercury__io:'ML_make_io_res_1_ok_file_type'(
mercury__io:'ML_file_type_regular'());
+ symlink ->
+ Result = mercury__io:'ML_make_io_res_1_ok_file_type'(
+ mercury__io:'ML_file_type_symbolic_link'());
other ->
Result = mercury__io:'ML_make_io_res_1_ok_file_type'(
mercury__io:'ML_file_type_unknown'())
@@ -3206,6 +3210,8 @@
"ML_file_type_symbolic_link").
:- pragma foreign_export("IL", file_type_symbolic_link = out,
"ML_file_type_symbolic_link").
+:- pragma foreign_export("Erlang", file_type_symbolic_link = out,
+ "ML_file_type_symbolic_link").
:- pragma foreign_export("C", file_type_regular = out,
"ML_file_type_regular").
:- pragma foreign_export("IL", file_type_regular = out,
@@ -3333,6 +3339,51 @@
}
").
+:- pragma foreign_proc("Erlang",
+ io.check_file_accessibility_2(FileName::in, AccessTypes::in, Result::out,
+ _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
+ does_not_affect_liveness],
+"
+ FileNameStr = binary_to_list(FileName),
+ case file:read_file_info(FileNameStr) of
+ {ok, FileInfo} ->
+ Access = FileInfo#file_info.access,
+ case mercury__io:'ML_access_types_includes_read'(AccessTypes) of
+ {} ->
+ Ok0 = lists:member(Access, [read, read_write]);
+ fail ->
+ Ok0 = true
+ end,
+ case Ok0 of
+ true ->
+ case
+ mercury__io:'ML_access_types_includes_write'(
+ AccessTypes)
+ of
+ {} ->
+ Ok = lists:member(Access, [write, read_write]);
+ fail ->
+ Ok = true
+ end;
+ false ->
+ Ok = Ok0
+ end,
+ % XXX test execute access somehow
+ case Ok of
+ true ->
+ Result = mercury__io:'ML_make_io_res_0_ok'();
+ false ->
+ Result = mercury__io:'ML_make_io_res_0_error'(eacces,
+ <<""file not accessible: "">>)
+ end
+ ;
+ {error, Reason} ->
+ Result = mercury__io:'ML_make_io_res_0_error'(Reason,
+ <<""file not accessible: "">>)
+ end
+").
+
:- pred io.check_file_accessibility_dotnet(string::in, list(access_type)::in,
io.res::out, io::di, io::uo) is det.
@@ -3522,6 +3573,8 @@
"ML_make_io_res_0_ok").
:- pragma foreign_export("IL", (make_io_res_0_ok = out),
"ML_make_io_res_0_ok").
+:- pragma foreign_export("Erlang", (make_io_res_0_ok = out),
+ "ML_make_io_res_0_ok").
make_io_res_0_ok = ok.
@@ -3531,6 +3584,8 @@
"ML_make_io_res_0_error").
:- pragma foreign_export("IL", make_io_res_0_error(in, in, out, di, uo),
"ML_make_io_res_0_error").
+:- pragma foreign_export("Erlang", make_io_res_0_error(in, in, out, di, uo),
+ "ML_make_io_res_0_error").
make_io_res_0_error(Error, Msg0, error(make_io_error(Msg)), !IO) :-
io.make_err_msg(Error, Msg0, Msg, !IO).
@@ -3593,6 +3648,8 @@
:- type file_id ---> file_id.
:- pragma foreign_type("C", file_id, "ML_File_Id")
where comparison is compare_file_id.
+:- pragma foreign_type("Erlang", file_id, "")
+ where comparison is compare_file_id.
:- pragma foreign_decl("C",
"
@@ -3631,7 +3688,8 @@
:- pragma foreign_proc("C",
compare_file_id_2(Res::out, FileId1::in, FileId2::in),
- [will_not_call_mercury, promise_pure, thread_safe, does_not_affect_liveness],
+ [will_not_call_mercury, promise_pure, thread_safe,
+ does_not_affect_liveness],
"
int device_cmp;
int inode_cmp;
@@ -3652,9 +3710,9 @@
} else {
inode_cmp = memcmp(&(FileId1.inode), &(FileId2.inode),
sizeof(ML_ino_t));
- if (device_cmp < 0) {
+ if (inode_cmp < 0) {
Res = -1;
- } else if (device_cmp > 0) {
+ } else if (inode_cmp > 0) {
Res = 1;
} else {
Res = 0;
@@ -3670,6 +3728,21 @@
""File IDs are not supported by Java."");
").
+:- pragma foreign_proc("Erlang",
+ compare_file_id_2(Res::out, FileId1::in, FileId2::in),
+ [will_not_call_mercury, promise_pure, thread_safe,
+ does_not_affect_liveness],
+"
+ if
+ FileId1 =:= FileId2 ->
+ Res = 0;
+ FileId1 < FileId2 ->
+ Res = -1;
+ true ->
+ Res = 1
+ end
+").
+
io.file_id(FileName, Result, !IO) :-
( have_file_ids ->
io.file_id_2(FileName, Status, Msg, FileId, !IO),
@@ -3724,6 +3797,26 @@
}
").
+:- pragma foreign_proc("Erlang",
+ io.file_id_2(FileName::in, Status::out, Msg::out,
+ FileId::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
+ FileNameStr = binary_to_list(FileName),
+ case file:read_file_info(FileNameStr) of
+ {ok, FileInfo} ->
+ MajorDevice = FileInfo#file_info.major_device,
+ Inode = FileInfo#file_info.inode,
+ FileId = {MajorDevice, Inode},
+ Msg = <<>>,
+ Status = 1;
+ {error, Reason} ->
+ FileId = null,
+ Msg = list_to_binary(file:format_error(Reason)),
+ Status = 0
+ end
+").
+
% Can we retrieve inode numbers on this system.
have_file_ids :- semidet_fail.
:- pragma foreign_proc("C",
@@ -3739,6 +3832,14 @@
#endif
").
+:- pragma foreign_proc("Erlang",
+ have_file_ids,
+ [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness],
+"
+ SUCCESS_INDICATOR = true
+").
+
%-----------------------------------------------------------------------------%
% A `buffer' is just an array of Chars.
@@ -10352,9 +10453,10 @@
LinkFileNameStr = binary_to_list(LinkFileName),
case file:make_symlink(FileNameStr, LinkFileNameStr) of
ok ->
- Status = 0;
- {error, _Reason} ->
- Status = -1
+ Status = 1;
+ {error, Reason} ->
+ put('MR_io_exception', Reason),
+ Status = 0
end
").
Index: tests/hard_coded/dir_test.exp2
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/dir_test.exp2,v
retrieving revision 1.3
diff -u -r1.3 dir_test.exp2
--- tests/hard_coded/dir_test.exp2 21 Sep 2007 03:21:35 -0000 1.3
+++ tests/hard_coded/dir_test.exp2 26 Sep 2007 01:07:17 -0000
@@ -158,5 +158,5 @@
test_dir/d1, test_dir/d1/bar, test_dir/d1/baz, test_dir/d1/foo, test_dir/d1/parent, test_dir/d2, test_dir/d2/d2, test_dir/d3, test_dir/quark, test_dir/queeg
dir__recursive_foldl2 (symlinks) succeeded
Files in test_dir (recursive, following symlinks:
-test_dir/d1, test_dir/d1/bar, test_dir/d1/baz, test_dir/d1/foo, test_dir/d1/parent, test_dir/d2, test_dir/d2/d2, test_dir/d3, test_dir/quark, test_dir/queeg
+test_dir/d1, test_dir/d1/bar, test_dir/d1/baz, test_dir/d1/foo, test_dir/d1/parent, test_dir/d2, test_dir/d2/d2, test_dir/d3, test_dir/d3/bar, test_dir/d3/baz, test_dir/d3/foo, test_dir/d3/parent, test_dir/quark, test_dir/queeg
dir.recursive_foldl2(list_files, "dir_test.m", ...) failed as expected.
Index: tests/hard_coded/dir_test.exp3
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/hard_coded/dir_test.exp3,v
retrieving revision 1.2
diff -u -r1.2 dir_test.exp3
--- tests/hard_coded/dir_test.exp3 28 Jul 2003 15:50:45 -0000 1.2
+++ tests/hard_coded/dir_test.exp3 26 Sep 2007 01:07:17 -0000
@@ -131,6 +131,7 @@
"foo/"/"bar/baz" = "foo/bar/baz".
checking whether `unwritable' is readable...ok
unwritable file found to be unwritable
+current_directory succeeded: hard_coded
make_directory succeeded
make_directory succeeded
dir.make_single_directory with non-existent parent failed as expected.
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list