diff --git a/CHANGES.md b/CHANGES.md index 23a63c84bf..443bd1d74d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +# dev + +## Features/Changes +* Runtime: support more Unix functions (#1829) + # 6.0.1 (2025-02-07) - Lille ## Features/Changes diff --git a/compiler/tests-check-prim/main.4.14.output b/compiler/tests-check-prim/main.4.14.output index 837ad8207f..94bb240abc 100644 --- a/compiler/tests-check-prim/main.4.14.output +++ b/compiler/tests-check-prim/main.4.14.output @@ -139,18 +139,27 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -158,6 +167,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -175,14 +185,17 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink caml_unix_utimes caml_unix_write +unix_error_message diff --git a/compiler/tests-check-prim/main.5.2.output b/compiler/tests-check-prim/main.5.2.output index bd6a3fa76b..973ddcb677 100644 --- a/compiler/tests-check-prim/main.5.2.output +++ b/compiler/tests-check-prim/main.5.2.output @@ -135,18 +135,27 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -154,6 +163,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -172,15 +182,18 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink caml_unix_utimes caml_unix_write caml_unix_write_bigarray +unix_error_message diff --git a/compiler/tests-check-prim/main.5.3.output b/compiler/tests-check-prim/main.5.3.output index d1f580ea3e..af47aa226e 100644 --- a/compiler/tests-check-prim/main.5.3.output +++ b/compiler/tests-check-prim/main.5.3.output @@ -133,18 +133,27 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -152,6 +161,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -170,15 +180,18 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink caml_unix_utimes caml_unix_write caml_unix_write_bigarray +unix_error_message diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output index 7922e02de5..d6634cabe7 100644 --- a/compiler/tests-check-prim/unix-Unix.4.14.output +++ b/compiler/tests-check-prim/unix-Unix.4.14.output @@ -18,11 +18,8 @@ caml_reset_afl_instrumentation caml_unix_map_file_bytecode debugger unix_accept -unix_access unix_alarm unix_bind -unix_chdir -unix_chmod unix_chown unix_chroot unix_clear_close_on_exec @@ -32,22 +29,13 @@ unix_dup unix_dup2 unix_environment unix_environment_unsafe -unix_error_message unix_execv unix_execve unix_execvp unix_execvpe -unix_fchmod unix_fchown unix_fork -unix_fsync unix_getaddrinfo -unix_getcwd -unix_getegid -unix_geteuid -unix_getgid -unix_getgrgid -unix_getgrnam unix_getgroups unix_gethostbyaddr unix_gethostbyname @@ -60,14 +48,12 @@ unix_getpid unix_getppid unix_getprotobyname unix_getprotobynumber -unix_getpwnam unix_getservbyname unix_getservbyport unix_getsockname unix_getsockopt unix_initgroups unix_kill -unix_link unix_listen unix_lockf unix_mkfifo @@ -92,7 +78,6 @@ unix_shutdown unix_sigpending unix_sigprocmask unix_sigsuspend -unix_single_write unix_sleep unix_socket unix_socketpair @@ -104,7 +89,6 @@ unix_tcflush unix_tcgetattr unix_tcsendbreak unix_tcsetattr -unix_times unix_umask unix_wait unix_waitpid @@ -231,18 +215,26 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -250,6 +242,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -267,11 +260,13 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink diff --git a/compiler/tests-check-prim/unix-Unix.5.2.output b/compiler/tests-check-prim/unix-Unix.5.2.output index 25663a23da..02ee9d3515 100644 --- a/compiler/tests-check-prim/unix-Unix.5.2.output +++ b/compiler/tests-check-prim/unix-Unix.5.2.output @@ -9,11 +9,8 @@ caml_drop_continuation caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_alarm caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_chown caml_unix_chroot caml_unix_clear_close_on_exec @@ -23,22 +20,13 @@ caml_unix_dup caml_unix_dup2 caml_unix_environment caml_unix_environment_unsafe -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe -caml_unix_fchmod caml_unix_fchown caml_unix_fork -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd -caml_unix_getegid -caml_unix_geteuid -caml_unix_getgid -caml_unix_getgrgid -caml_unix_getgrnam caml_unix_getgroups caml_unix_gethostbyaddr caml_unix_gethostbyname @@ -51,14 +39,12 @@ caml_unix_getpid caml_unix_getppid caml_unix_getprotobyname caml_unix_getprotobynumber -caml_unix_getpwnam caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt caml_unix_initgroups caml_unix_kill -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -84,7 +70,6 @@ caml_unix_shutdown caml_unix_sigpending caml_unix_sigprocmask caml_unix_sigsuspend -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair @@ -96,7 +81,6 @@ caml_unix_tcflush caml_unix_tcgetattr caml_unix_tcsendbreak caml_unix_tcsetattr -caml_unix_times caml_unix_umask caml_unix_wait caml_unix_waitpid @@ -227,10 +211,12 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror caml_unix_cleanup caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_startup +unix_error_message diff --git a/compiler/tests-check-prim/unix-Unix.5.3.output b/compiler/tests-check-prim/unix-Unix.5.3.output index 4184d40762..1c8c4155fd 100644 --- a/compiler/tests-check-prim/unix-Unix.5.3.output +++ b/compiler/tests-check-prim/unix-Unix.5.3.output @@ -8,11 +8,8 @@ caml_continuation_use caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_alarm caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_chown caml_unix_chroot caml_unix_clear_close_on_exec @@ -22,22 +19,13 @@ caml_unix_dup caml_unix_dup2 caml_unix_environment caml_unix_environment_unsafe -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe -caml_unix_fchmod caml_unix_fchown caml_unix_fork -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd -caml_unix_getegid -caml_unix_geteuid -caml_unix_getgid -caml_unix_getgrgid -caml_unix_getgrnam caml_unix_getgroups caml_unix_gethostbyaddr caml_unix_gethostbyname @@ -50,14 +38,12 @@ caml_unix_getpid caml_unix_getppid caml_unix_getprotobyname caml_unix_getprotobynumber -caml_unix_getpwnam caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt caml_unix_initgroups caml_unix_kill -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -83,7 +69,6 @@ caml_unix_shutdown caml_unix_sigpending caml_unix_sigprocmask caml_unix_sigsuspend -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair @@ -95,7 +80,6 @@ caml_unix_tcflush caml_unix_tcgetattr caml_unix_tcsendbreak caml_unix_tcsetattr -caml_unix_times caml_unix_umask caml_unix_wait caml_unix_waitpid @@ -225,10 +209,12 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_strerror caml_unix_cleanup caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_startup +unix_error_message diff --git a/compiler/tests-check-prim/unix-Win32.4.14.output b/compiler/tests-check-prim/unix-Win32.4.14.output index ce3b1b2851..80dfdc0f2b 100644 --- a/compiler/tests-check-prim/unix-Win32.4.14.output +++ b/compiler/tests-check-prim/unix-Win32.4.14.output @@ -18,23 +18,17 @@ caml_reset_afl_instrumentation caml_unix_map_file_bytecode debugger unix_accept -unix_access unix_bind -unix_chdir -unix_chmod unix_clear_nonblock unix_connect unix_dup unix_dup2 unix_environment -unix_error_message unix_execv unix_execve unix_execvp unix_execvpe -unix_fsync unix_getaddrinfo -unix_getcwd unix_gethostbyaddr unix_gethostbyname unix_gethostname @@ -47,7 +41,6 @@ unix_getservbyname unix_getservbyport unix_getsockname unix_getsockopt -unix_link unix_listen unix_lockf unix_pipe @@ -61,12 +54,10 @@ unix_sendto unix_set_nonblock unix_setsockopt unix_shutdown -unix_single_write unix_sleep unix_socket unix_socketpair unix_string_of_inet_addr -unix_times win_clear_close_on_exec win_create_process win_set_close_on_exec @@ -196,18 +187,26 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: +caml_unix_access +caml_unix_chdir +caml_unix_chmod caml_unix_cleanup caml_unix_close caml_unix_closedir +caml_unix_fchmod caml_unix_filedescr_of_fd caml_unix_findclose caml_unix_findfirst caml_unix_findnext caml_unix_fstat caml_unix_fstat_64 +caml_unix_fsync caml_unix_ftruncate caml_unix_ftruncate_64 -caml_unix_getpwuid +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_gettimeofday caml_unix_getuid caml_unix_gmtime @@ -215,6 +214,7 @@ caml_unix_has_symlink caml_unix_inchannel_of_filedescr caml_unix_inet_addr_of_string caml_unix_isatty +caml_unix_link caml_unix_localtime caml_unix_lookup_file caml_unix_lseek @@ -232,11 +232,13 @@ caml_unix_readlink caml_unix_rename caml_unix_rewinddir caml_unix_rmdir +caml_unix_single_write caml_unix_startup caml_unix_stat caml_unix_stat_64 caml_unix_symlink caml_unix_time +caml_unix_times caml_unix_truncate caml_unix_truncate_64 caml_unix_unlink diff --git a/compiler/tests-check-prim/unix-Win32.5.2.output b/compiler/tests-check-prim/unix-Win32.5.2.output index e556d8cbee..4abee14701 100644 --- a/compiler/tests-check-prim/unix-Win32.5.2.output +++ b/compiler/tests-check-prim/unix-Win32.5.2.output @@ -9,10 +9,7 @@ caml_drop_continuation caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_clear_close_on_exec caml_unix_clear_nonblock caml_unix_connect @@ -20,15 +17,12 @@ caml_unix_create_process caml_unix_dup caml_unix_dup2 caml_unix_environment -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe caml_unix_filedescr_of_channel -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd caml_unix_gethostbyaddr caml_unix_gethostbyname caml_unix_gethostname @@ -41,7 +35,6 @@ caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -57,14 +50,12 @@ caml_unix_set_close_on_exec caml_unix_set_nonblock caml_unix_setsockopt caml_unix_shutdown -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair caml_unix_string_of_inet_addr caml_unix_system caml_unix_terminate_process -caml_unix_times caml_unix_waitpid debugger @@ -193,7 +184,13 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: -caml_unix_getpwuid +caml_strerror +caml_unix_fchmod +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_getuid caml_unix_rewinddir +unix_error_message diff --git a/compiler/tests-check-prim/unix-Win32.5.3.output b/compiler/tests-check-prim/unix-Win32.5.3.output index 3259dfbe8b..fdd7c21ad6 100644 --- a/compiler/tests-check-prim/unix-Win32.5.3.output +++ b/compiler/tests-check-prim/unix-Win32.5.3.output @@ -8,10 +8,7 @@ caml_continuation_use caml_int_as_pointer caml_reset_afl_instrumentation caml_unix_accept -caml_unix_access caml_unix_bind -caml_unix_chdir -caml_unix_chmod caml_unix_clear_close_on_exec caml_unix_clear_nonblock caml_unix_connect @@ -19,15 +16,12 @@ caml_unix_create_process caml_unix_dup caml_unix_dup2 caml_unix_environment -caml_unix_error_message caml_unix_execv caml_unix_execve caml_unix_execvp caml_unix_execvpe caml_unix_filedescr_of_channel -caml_unix_fsync caml_unix_getaddrinfo -caml_unix_getcwd caml_unix_gethostbyaddr caml_unix_gethostbyname caml_unix_gethostname @@ -40,7 +34,6 @@ caml_unix_getservbyname caml_unix_getservbyport caml_unix_getsockname caml_unix_getsockopt -caml_unix_link caml_unix_listen caml_unix_lockf caml_unix_map_file_bytecode @@ -56,14 +49,12 @@ caml_unix_set_close_on_exec caml_unix_set_nonblock caml_unix_setsockopt caml_unix_shutdown -caml_unix_single_write caml_unix_sleep caml_unix_socket caml_unix_socketpair caml_unix_string_of_inet_addr caml_unix_system caml_unix_terminate_process -caml_unix_times caml_unix_waitpid debugger @@ -191,7 +182,13 @@ jsoo_toplevel_init_compile jsoo_toplevel_init_reloc From +unix.js: -caml_unix_getpwuid +caml_strerror +caml_unix_fchmod +caml_unix_getegid +caml_unix_geteuid +caml_unix_getgid +caml_unix_getpwnam caml_unix_getuid caml_unix_rewinddir +unix_error_message diff --git a/compiler/tests-io/non_ascii_filenames.ml b/compiler/tests-io/non_ascii_filenames.ml index 437ae89d4b..f32136e9fe 100644 --- a/compiler/tests-io/non_ascii_filenames.ml +++ b/compiler/tests-io/non_ascii_filenames.ml @@ -13,14 +13,7 @@ let () = Printf.printf "reading directories\n"; let check_file d = let a = Sys.readdir d in - if - not - (Array.exists - (fun x -> - prerr_endline x; - x = "accentué") - a) - then raise Not_found + if not (Array.exists (fun x -> x = "accentué") a) then raise Not_found in test check_file "."; test check_file "/static"; diff --git a/compiler/tests-jsoo/dune b/compiler/tests-jsoo/dune index faf7fd7f64..7ccd92ca4e 100644 --- a/compiler/tests-jsoo/dune +++ b/compiler/tests-jsoo/dune @@ -1,3 +1,9 @@ +(env + (_ + ;; for testing + (env-vars + (FOO bar)))) + (library (name jsoo_testsuite_latest) (modules test_io test_floats) diff --git a/compiler/tests-jsoo/test_unix.ml b/compiler/tests-jsoo/test_unix.ml new file mode 100644 index 0000000000..aa25c0baad --- /dev/null +++ b/compiler/tests-jsoo/test_unix.ml @@ -0,0 +1,156 @@ +let%expect_test "Unix.error_message" = + Printf.printf "%s\n" (String.lowercase_ascii (Unix.error_message ENOENT)); + [%expect {| no such file or directory |}] + +let%expect_test "Unix.times" = + let t = Unix.times () in + let t' = Unix.times () in + let cmp v v' = v' >= v && v' <= v +. 0.1 in + if + cmp t.tms_utime t'.tms_utime + && cmp t.tms_stime t'.tms_stime + && cmp t.tms_cutime t'.tms_cutime + && cmp t.tms_cstime t'.tms_cstime + then Printf.printf "OK\n"; + [%expect {| OK |}] + +let on_windows = Sys.os_type = "Win32" + +let%expect_test "Unix.chmod / Unix.fchmod / Unix.access" = + let tmp = Filename.temp_file "a" "txt" in + let test ?(ok_on_windows = false) flags = + try + Unix.access tmp flags; + if on_windows && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "success\n" + with + | Unix.Unix_error ((EPERM | EACCES), _, _) -> + if (not on_windows) && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "denied\n" + | Unix.Unix_error (ENOENT, _, _) -> Printf.printf "absent\n" + in + let touch perms = + Unix.chmod tmp 0o600; + Unix.unlink tmp; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] perms in + Unix.close fd + in + let test_perms set = + set 0o200; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test ~ok_on_windows:true [ R_OK; W_OK ]; + [%expect + {| + denied (success on Windows) + success + denied (success on Windows) + |}]; + set 0o400; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + denied + denied |}]; + set 0o600; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + success + success |}]; + set 0o000; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + denied (success on Windows) + denied + denied + |}] + in + test [ F_OK ]; + [%expect {| + success |}]; + Unix.chmod tmp 0o600; + Unix.unlink tmp; + test [ F_OK ]; + [%expect {| + absent |}]; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in + test [ F_OK ]; + [%expect {| + success |}]; + if not on_windows then test_perms (Unix.fchmod fd); + Unix.close fd; + test_perms (Unix.chmod tmp); + test_perms touch; + Unix.chmod tmp 0o600; + Unix.unlink tmp + +let%expect_test "Unix.link" = + let tmp = Filename.temp_file "a" "txt" in + let ch = open_out tmp in + output_string ch "test\n"; + close_out ch; + let tmp' = Filename.temp_file "a" "txt" in + Unix.unlink tmp'; + Unix.link tmp tmp'; + let ch = open_in tmp' in + Format.printf "%s\n" (input_line ch); + close_in ch; + let ch = open_out tmp' in + output_string ch "abcd\n"; + close_out ch; + let ch = open_in tmp in + Format.printf "%s\n" (input_line ch); + close_in ch; + Unix.unlink tmp; + Unix.unlink tmp'; + [%expect {| + test + abcd + |}] + +let%expect_test "Unix.readlink" = + let tmp' = Filename.temp_file "a" "txt" in + Unix.unlink tmp'; + Unix.symlink "abcdefgh" tmp'; + Format.printf "%s\n" (Unix.readlink tmp'); + [%expect {| abcdefgh |}] + +let%expect_test "Unix.single_write" = + let s = "abcd efgh ijkl mnop qrst uvwx" in + let b = Bytes.of_string s in + let tmp = Filename.temp_file "a" "txt" in + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in + let n = Unix.single_write fd b 0 (Bytes.length b) in + Unix.close fd; + let ch = open_in tmp in + let s' = really_input_string ch n in + Printf.printf "%b %b\n" (n > 0) (s' = String.sub s 0 n); + [%expect {| true true |}] + +let%expect_test "Unix.read" = + let tmp = Filename.temp_file "a" "txt" in + let fd = Unix.openfile tmp [ O_RDONLY ] 0o666 in + (try Printf.printf "write: %d\n" (Unix.write fd (Bytes.create 8) 0 8) + with Unix.Unix_error (_, _, _) -> Printf.printf "write failed\n"); + Unix.close fd; + Unix.unlink tmp; + (try Printf.printf "read: %d\n" (Unix.read fd (Bytes.create 8) 0 8) + with Unix.Unix_error (err, _, _) -> + Printf.printf "%s\n" (String.lowercase_ascii (Unix.error_message err))); + [%expect {| + write failed + bad file descriptor + |}] + +let%expect_test "Unix.getenv" = + Printf.printf "%s\n" (Sys.getenv "FOO"); + [%expect {| bar |}] diff --git a/compiler/tests-ocaml/lib-marshal/compressed.ml b/compiler/tests-ocaml/lib-marshal/compressed.ml index 841cb94640..9d3b0440e2 100644 --- a/compiler/tests-ocaml/lib-marshal/compressed.ml +++ b/compiler/tests-ocaml/lib-marshal/compressed.ml @@ -161,8 +161,8 @@ let test_supported filename = if false then test 100 (actually_supported = compression_supported) let main () = - test_out "intext.data"; test_in "intext.data"; - test_supported "intext.data"; - Sys.remove "intext.data" + test_out "intext_compressed.data"; test_in "intext_compressed.data"; + test_supported "intext_compressed.data"; + Sys.remove "intext_compressed.data" let _ = main () diff --git a/compiler/tests-ocaml/win-unicode/dune b/compiler/tests-ocaml/win-unicode/dune new file mode 100644 index 0000000000..08585c87e9 --- /dev/null +++ b/compiler/tests-ocaml/win-unicode/dune @@ -0,0 +1,4 @@ +(tests + (names mltest) + (libraries ocaml_testing unix) + (modes js wasm)) diff --git a/compiler/tests-ocaml/win-unicode/mltest.ml b/compiler/tests-ocaml/win-unicode/mltest.ml new file mode 100644 index 0000000000..5c750eb231 --- /dev/null +++ b/compiler/tests-ocaml/win-unicode/mltest.ml @@ -0,0 +1,293 @@ +(* TEST + include unix; + hasunix; + flags += "-strict-sequence -w +A -warn-error +A"; + windows-unicode; + toplevel; +*) + +let foreign_names = + List.sort compare + [ + "simple"; + "\xE4\xBD\xA0\xE5\xA5\xBD"; (* "你好" *) + "\x73\xC5\x93\x75\x72"; (* "sœur" *) + "e\204\129te\204\129"; (* "été" *) + ] +;; + +let test_files = + List.map (fun s -> s ^ ".txt") foreign_names +;; + +let to_create_and_delete_files = + [ + (* "верблюды" *) + "\xD0\xB2\xD0\xB5\xD1\x80\xD0\xB1\xD0\xBB\xD1\x8E\xD0\xB4\xD1\x8B"; + "\xE9\xAA\x86\xE9\xA9\xBC"; (* "骆驼" *) + "\215\167\215\162\215\158\215\156"; (* "קעמל" *) + "\216\167\217\136\217\134\217\185"; (* "اونٹ" *) + "L\225\186\161c \196\145\195\160"; (* "Lạc đà" *) + "\224\176\146\224\176\130\224\176\159\224\177\134"; (* "ఒంటె" *) + "\224\174\146\224\174\159\224\175\141\224\174\159\224\174\149\224\ + \174\174\224\175\141"; (* "ஒட்டகம்" *) + "\217\136\216\180\216\170\216\177"; (* "وشتر" *) + "\224\164\137\224\164\183\224\165\141\224\164\159\224\165\141\224\ + \164\176\224\164\131"; (* "उष्ट्रः" *) + "\216\167\217\186"; (* "اٺ" *) + ] +;; + +let foreign_names2 = + let rec take n l = + if n = 0 then [] + else List.hd l :: take (n-1) (List.tl l) + in + take (List.length foreign_names) to_create_and_delete_files +;; + +(* let env0 = + List.sort compare + (List.mapi (fun i v -> Printf.sprintf "OCAML_UTF8_VAR%d=%s" i v) + foreign_names2) *) + +(* let read_all ic = *) +(* set_binary_mode_in ic false; *) +(* let rec loop acc = *) +(* match input_line ic with *) +(* | exception End_of_file -> *) +(* List.rev acc *) +(* | s -> *) +(* loop (s :: acc) *) +(* in *) +(* loop [] *) + +(** WRAPPERS *) + +let getenvironmentenv s = + let env = Unix.environment () in + let rec loop i = + if i >= Array.length env then + "" + else begin + let e = env.(i) in + let pos = String.index e '=' in + if String.sub e 0 pos = s then + String.sub e (pos+1) (String.length e - pos - 1) + else + loop (i+1) + end + in + loop 0 +;; + +let unix_getcwd () = + Filename.basename (Unix.getcwd ()) +;; + +let sys_getcwd () = + Filename.basename (Sys.getcwd ()) +;; + +let unix_readdir s = + let h = Unix.opendir s in + let rec loop acc = + match Unix.readdir h with + | s -> + loop (s :: acc) + | exception End_of_file -> + Unix.closedir h; + acc + in + List.sort compare (loop []) +;; + +let sys_readdir s = + List.sort compare (Array.to_list (Sys.readdir s)) +;; + +(* let open_process_in cmdline = *) +(* let f cmdline = *) +(* let ic as proc = Unix.open_process_in cmdline in *) +(* let l = List.tl (read_all ic) in *) +(* ignore (Unix.close_process_in proc); *) +(* l *) +(* in *) +(* wrap "Unix.open_process_in" f ell cmdline (list quote) *) + +(* let open_process_full filter cmdline env = + let f cmdline env = + let (ic, _, _) as proc = + Unix.open_process_full cmdline (Array.of_list env) + in + let l = read_all ic in + ignore (Unix.close_process_full proc); + List.sort compare (List.filter filter l) + in + wrap2 "Unix.open_process_full" f ell (list quote) cmdline env (list quote) +*) + +let test_readdir readdir = + let filter s = List.mem s test_files && Filename.check_suffix s ".txt" in + List.filter filter (readdir Filename.current_dir_name) +;; + +let test_open_in () = + let check s = + let ic = open_in s in + let l = input_line ic in + close_in ic; + l + in + let filter s = List.mem s test_files in + let files = List.filter filter (sys_readdir Filename.current_dir_name) in + List.map check files +;; + +(* putenv not implemented +let test_getenv () = + let equiv l r = + assert (l = r); + l, r + in + let doit key s = + Unix.putenv key s; + let l = equiv (Sys.getenv key) (getenvironmentenv key) in + let r = + Unix.putenv key (s ^ s); + equiv (Sys.getenv key) (getenvironmentenv key) + in + l, r + in + List.map2 doit foreign_names foreign_names2 +;; +*) + +let test_mkdir () = + let doit s = + Unix.mkdir s 0o755; + Sys.file_exists s, Sys.is_directory s + in + List.map doit foreign_names +;; + +let test_chdir chdir getcwd = + let curr = Sys.getcwd () in + let doit s = + chdir s; + let d = getcwd () in + chdir curr; + d + in + List.map doit foreign_names +;; + +let test_rmdir () = + let doit s = + Unix.rmdir s; + Sys.file_exists s + in + List.map doit foreign_names +;; + +let test_stat () = + let doit s = + (Unix.stat s).Unix.st_kind, + (Unix.lstat s).Unix.st_kind, + (Unix.LargeFile.stat s).Unix.LargeFile.st_kind, + (Unix.LargeFile.lstat s).Unix.LargeFile.st_kind + in + List.map doit to_create_and_delete_files +;; + +let test_access () = + List.iter (fun s -> Unix.access s [Unix.F_OK]) to_create_and_delete_files + +let test_rename rename = + let doit s = + let s' = s ^ "-1" in + rename s s'; + let x = Sys.file_exists s, Sys.file_exists s' in + rename s' s; + let y = Sys.file_exists s, Sys.file_exists s' in + x, y + in + List.map doit to_create_and_delete_files +;; + +let test_open_out () = + let doit s = + let oc = open_out s in + Printf.fprintf oc "Hello, %s\n" s; + close_out oc; + let ic = open_in s in + let l = input_line ic in + close_in ic; + l + in + List.map doit to_create_and_delete_files +;; + +let test_file_exists () = + List.map Sys.file_exists to_create_and_delete_files +;; + +let test_remove () = + let doit s = + Sys.remove s; + Sys.file_exists s + in + List.map doit to_create_and_delete_files +;; + +let create_file s = + let oc = open_out_bin s in + output_string oc s; + close_out oc +;; + +let test_symlink () = + let foodir = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD" (* "UNIQU你好" *) in + let foofile = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD/\xE4\xBD\xA0\xE5\xA5\xBD.txt" + (* "UNIQU你好/你好.txt" *) + in + let fileln = "\xE4\xBD\xA0\xE5\xA5\xBD-file-ln-s" (* "你好-file-ln-s" *) in + let dirln = "\xE4\xBD\xA0\xE5\xA5\xBD-dir-ln-s" (* "你好-dir-ln-s" *) in + Unix.mkdir foodir 0o777; + create_file foofile; + Unix.symlink ~to_dir:true foodir dirln; + Unix.symlink ~to_dir:false foofile fileln; + let res = + (Unix.stat fileln).Unix.st_kind = Unix.S_REG && + (Unix.lstat fileln).Unix.st_kind = Unix.S_LNK +(* node cannot stat a link to a directory under Windows (EPERM) +&& (Unix.stat dirln).Unix.st_kind = Unix.S_DIR +&& (Unix.lstat dirln).Unix.st_kind = Unix.S_LNK *) + in + Sys.remove foofile; + Sys.remove fileln; + Sys.remove dirln; + Unix.rmdir foodir; + res +;; + +List.iter create_file test_files;; + +let check_length ?(n = 4) v = assert (List.length v = n);; + +let t_unix_readdir = check_length @@ test_readdir unix_readdir;; +let t_sys_readdir = check_length @@ test_readdir sys_readdir;; +let t_open_in = check_length @@ test_open_in ();; +let t_open_out = check_length ~n:10 @@ test_open_out ();; +let t_file_exists = assert (List.for_all Fun.id (test_file_exists ()));; +let t_stat = assert (List.for_all (fun x -> match x with Unix.S_REG,Unix.S_REG,Unix.S_REG,Unix.S_REG -> true | _ -> false) (test_stat ()));; +test_access ();; +let t_unix_rename = test_rename Unix.rename;; +let t_sys_rename = test_rename Sys.rename;; +assert (not (List.exists Fun.id (test_remove ())));; +assert (List.for_all (fun (p, q) -> p && q) (test_mkdir ()));; +let t_sys_chdir = assert (foreign_names = test_chdir Sys.chdir sys_getcwd);; +let t_unix_chdir = assert (foreign_names = test_chdir Unix.chdir unix_getcwd);; +assert (not (List.exists Fun.id (test_rmdir ())));; +(*let t_getenv = test_getenv ();;*) +assert (if Unix.has_symlink () then test_symlink () else true);; diff --git a/runtime/js/fs.js b/runtime/js/fs.js index dc8cfcb0da..db8002262b 100644 --- a/runtime/js/fs.js +++ b/runtime/js/fs.js @@ -198,13 +198,15 @@ function caml_unmount(name) { //Provides: caml_sys_getcwd //Requires: caml_current_dir, caml_string_of_jsstring +//Alias: caml_unix_getcwd +//Alias: unix_getcwd function caml_sys_getcwd() { return caml_string_of_jsstring(caml_current_dir); } //Provides: caml_sys_chdir -//Requires: caml_current_dir, caml_raise_no_such_file, resolve_fs_device, caml_trailing_slash, caml_jsstring_of_string, caml_raise_sys_error -function caml_sys_chdir(dir) { +//Requires: caml_current_dir, caml_raise_no_such_file, resolve_fs_device, caml_trailing_slash, caml_jsstring_of_string, caml_raise_system_error +function caml_sys_chdir(dir, raise_unix) { var root = resolve_fs_device(dir); if (root.device.is_dir(root.rest)) { if (root.rest) @@ -212,11 +214,15 @@ function caml_sys_chdir(dir) { else caml_current_dir = root.path; return 0; } else if (root.device.exists(root.rest)) { - caml_raise_sys_error( - "ENOTDIR: not a directory, chdir '" + caml_jsstring_of_string(dir) + "'", + caml_raise_system_error( + raise_unix, + "ENOTDIR", + "chdir", + "not a directory", + caml_jsstring_of_string(dir), ); } else { - caml_raise_no_such_file(caml_jsstring_of_string(dir)); + caml_raise_no_such_file(caml_jsstring_of_string(dir), raise_unix); } } diff --git a/runtime/js/fs_fake.js b/runtime/js/fs_fake.js index d5af726d7a..0273b9a8bb 100644 --- a/runtime/js/fs_fake.js +++ b/runtime/js/fs_fake.js @@ -203,6 +203,23 @@ MlFakeDevice.prototype.unlink = function (name, raise_unix) { delete this.content[name]; return 0; }; +MlFakeDevice.prototype.access = function (name, f, raise_unix) { + var file; + this.lookup(name); + if (this.content[name]) { + if (this.is_dir(name)) + caml_raise_system_error( + raise_unix, + "EACCESS", + "access", + "permission denied,", + this.nm(name), + ); + } else { + caml_raise_no_such_file(this.nm(name), raise_unix); + } + return 0; +}; MlFakeDevice.prototype.open = function (name, f, _perms, raise_unix) { var file; this.lookup(name); diff --git a/runtime/js/fs_node.js b/runtime/js/fs_node.js index 5085c87d11..38be7f8cfb 100644 --- a/runtime/js/fs_node.js +++ b/runtime/js/fs_node.js @@ -113,6 +113,33 @@ MlNodeDevice.prototype.truncate = function (name, len, raise_unix) { caml_raise_nodejs_error(err, raise_unix); } }; +MlNodeDevice.prototype.access = function (name, f, raise_unix) { + var consts = require("node:constants"); + var res = 0; + for (var key in f) { + switch (key) { + case "r": + res |= consts.R_OK; + break; + case "w": + res |= consts.W_OK; + break; + case "x": + res |= + globalThis.process?.platform === "win32" ? consts.R_OK : consts.X_OK; + break; + case "f": + res |= consts.F_OK; + break; + } + } + try { + this.fs.accessSync(this.nm(name), res); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, raise_unix); + } +}; MlNodeDevice.prototype.open = function (name, f, perms, raise_unix) { var consts = require("node:constants"); var res = 0; @@ -226,6 +253,22 @@ MlNodeDevice.prototype.lstat = function (name, large, raise_unix) { caml_raise_nodejs_error(err, raise_unix); } }; +MlNodeDevice.prototype.chmod = function (name, perms, raise_unix) { + try { + this.fs.chmodSync(this.nm(name), perms); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, raise_unix); + } +}; +MlNodeDevice.prototype.link = function (target, path, raise_unix) { + try { + this.fs.linkSync(this.nm(target), this.nm(path)); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, raise_unix); + } +}; MlNodeDevice.prototype.symlink = function (to_dir, target, path, raise_unix) { try { this.fs.symlinkSync( @@ -409,6 +452,22 @@ MlNodeFd.prototype.stat = function (large) { caml_raise_nodejs_error(err, /* raise Unix_error */ 1); } }; +MlNodeFd.prototype.chmod = function (perms) { + try { + this.fs.fchmodSync(this.fd, perms); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, /* raise Unix_error */ 1); + } +}; +MlNodeFd.prototype.sync = function () { + try { + this.fs.fsyncSync(this.fd); + return 0; + } catch (err) { + caml_raise_nodejs_error(err, /* raise Unix_error */ 1); + } +}; MlNodeFd.prototype.close = function (raise_unix) { try { this.fs.closeSync(this.fd); diff --git a/runtime/js/unix.js b/runtime/js/unix.js index cb576e490e..46c29d8f19 100644 --- a/runtime/js/unix.js +++ b/runtime/js/unix.js @@ -11,6 +11,20 @@ function caml_unix_time() { return Math.floor(caml_unix_gettimeofday()); } +//Provides: caml_unix_times +//Requires: caml_failwith +//Alias: unix_times +function caml_unix_times() { + if (globalThis.process && globalThis.process.cpuUsage) { + var t = globalThis.process.cpuUsage(); + return BLOCK(0, t.user / 1e6, t.system / 1e6, 0, 0); + } else if (globalThis.performance && globalThis.performance.now) { + return BLOCK(0, globalThis.performance.now() / 1000, 0, 0, 0); + } else { + caml_failwith("caml_unix_times: not implemented"); + } +} + //Provides: caml_unix_gmtime //Alias: unix_gmtime function caml_unix_gmtime(t) { @@ -199,6 +213,36 @@ function make_unix_err_args(code, syscall, path, errno) { return args; } +//Provides: caml_strerror +//Requires: unix_error +function caml_strerror(errno) { + const util = require("node:util"); + if (errno >= 0) { + const code = unix_error[errno]; + return util + .getSystemErrorMap() + .entries() + .find((x) => x[1][0] === code)[1][1]; + } else { + return util.getSystemErrorMessage(errno); + } +} + +//Provides: unix_error_message +//Alias: caml_unix_error_message +//Requires: caml_strerror, caml_string_of_jsstring +function unix_error_message(err) { + const errno = typeof err === "number" ? err : -err[1]; + return caml_string_of_jsstring(caml_strerror(errno)); +} + +//Provides: caml_unix_chdir +//Requires: caml_sys_chdir +//Alias: unix_chdir +function caml_unix_chdir(dir) { + return caml_sys_chdir(dir, /* raise Unix_error */ true); +} + //Provides: caml_unix_stat //Requires: resolve_fs_device, caml_failwith //Alias: unix_stat @@ -259,6 +303,17 @@ function caml_unix_lstat_64(name) { ); } +//Provides: caml_unix_chmod +//Requires: resolve_fs_device, caml_failwith +//Alias: unix_chmod +function caml_unix_chmod(name, perms) { + var root = resolve_fs_device(name); + if (!root.device.chmod) { + caml_failwith("caml_unix_chmod: not implemented"); + } + return root.device.chmod(root.rest, perms); +} + //Provides: caml_unix_rename //Requires: caml_failwith, resolve_fs_device //Requires: caml_raise_system_error @@ -294,6 +349,26 @@ function caml_unix_rmdir(name) { return root.device.rmdir(root.rest, /* raise Unix_error */ true); } +//Provides: caml_unix_link +//Requires: resolve_fs_device, caml_failwith, caml_raise_system_error +//Alias: unix_link +function caml_unix_link(follow, src, dst) { + var src_root = resolve_fs_device(src); + var dst_root = resolve_fs_device(dst); + if (!src_root.device.link) { + caml_failwith("caml_unix_link: not implemented"); + } + if (typeof follow !== "number") + caml_raise_system_error(/* raise Unix_error */ 1, "ENOSYS", "link"); + if (src_root.device !== dst_root.device) + caml_raise_system_error(/* raise Unix_error */ 1, "EXDEV", "link"); + return src_root.device.link( + src_root.rest, + dst_root.rest, + /* raise Unix_error */ true, + ); +} + //Provides: caml_unix_symlink //Requires: resolve_fs_device, caml_failwith, caml_jsstring_of_string //Alias: unix_symlink @@ -373,6 +448,36 @@ function caml_unix_truncate_64(name, len) { return 0; } +//Provides: caml_unix_access +//Requires: resolve_fs_device, caml_failwith +//Alias: unix_access +function caml_unix_access(name, flags) { + var f = {}; + while (flags) { + switch (flags[1]) { + case 0: + f.r = 1; + break; + case 1: + f.w = 1; + break; + case 2: + f.x = 1; + break; + case 3: + f.f = 1; + break; + } + flags = flags[2]; + } + var root = resolve_fs_device(name); + if (!root.device.access) { + caml_failwith("caml_unix_access: not implemented"); + } + root.device.access(root.rest, f, /* raise Unix_error */ true); + return 0; +} + //Provides: caml_unix_open //Requires: resolve_fs_device, caml_sys_fds, MlChanid //Alias: unix_open @@ -455,6 +560,28 @@ function caml_unix_fstat_64(fd) { return file.stat(/* large */ true); } +//Provides: caml_unix_fchmod +//Alias: unix_fchmod +//Requires: caml_unix_lookup_file, caml_failwith +function caml_unix_fchmod(fd, perms) { + var file = caml_unix_lookup_file(fd, "fchmod"); + if (!file.chmod) { + caml_failwith("caml_unix_fchmod: not implemented"); + } + return file.chmod(perms); +} + +//Provides: caml_unix_fsync +//Alias: unix_fsync +//Requires: caml_unix_lookup_file, caml_failwith +function caml_unix_fsync(fd) { + var file = caml_unix_lookup_file(fd, "fsync"); + if (!file.sync) { + caml_failwith("caml_unix_fsync: not implemented"); + } + return file.sync(); +} + //Provides: caml_unix_write //Alias: unix_write //Requires: caml_unix_lookup_file, caml_uint8_array_of_bytes @@ -471,6 +598,20 @@ function caml_unix_write(fd, buf, pos, len) { return written; } +//Provides: caml_unix_single_write +//Alias: unix_single_write +//Requires: caml_unix_lookup_file, caml_uint8_array_of_bytes +function caml_unix_single_write(fd, buf, pos, len) { + var file = caml_unix_lookup_file(fd, "write"); + if (len === 0) return 0; + return file.write( + caml_uint8_array_of_bytes(buf), + pos, + len, + /* raise unix_error */ 1, + ); +} + //Provides: caml_unix_write_bigarray //Alias: caml_unix_lookup_file //Requires: caml_ba_to_typed_array, caml_unix_lookup_file @@ -589,10 +730,43 @@ function caml_unix_getuid(unit) { return 1; } -//Provides: caml_unix_getpwuid +//Provides: caml_unix_geteuid +//Alias: unix_geteuid +function caml_unix_geteuid(unit) { + if (globalThis.process && globalThis.process.geteuid) { + return globalThis.process.geteuid(); + } + return 1; +} + +//Provides: caml_unix_getgid +//Alias: unix_getgid +function caml_unix_getgid(unit) { + if (globalThis.process && globalThis.process.getgid) { + return globalThis.process.getgid(); + } + return 1; +} + +//Provides: caml_unix_getegid +//Alias: unix_getegid +function caml_unix_getegid(unit) { + if (globalThis.process && globalThis.process.getegid) { + return globalThis.process.getegid(); + } + return 1; +} + +//Provides: caml_unix_getpwnam //Requires: caml_raise_not_found +//Alias: unix_getpwnam +//Alias: caml_unix_getpwuid //Alias: unix_getpwuid -function caml_unix_getpwuid(unit) { +//Alias: caml_unix_getgrnam +//Alias: unix_getgrnam +//Alias: caml_unix_getgrgid +//Alias: unix_getgrgid +function caml_unix_getpwnam(unit) { caml_raise_not_found(); } diff --git a/runtime/wasm/deps.json b/runtime/wasm/deps.json index cb37130f87..4a2173c983 100644 --- a/runtime/wasm/deps.json +++ b/runtime/wasm/deps.json @@ -72,6 +72,15 @@ "import": ["bindings", "wrap_meth_callback_unsafe"], "reaches": ["callback"] }, + { + "name": "alloc_times", + "export": "caml_alloc_times" + }, + { + "name": "times", + "import": ["bindings", "times"], + "reaches": ["alloc_times"] + }, { "name": "alloc_tm", "export": "caml_alloc_tm" diff --git a/runtime/wasm/fs.wat b/runtime/wasm/fs.wat index e4ba3664a4..abe6dab066 100644 --- a/runtime/wasm/fs.wat +++ b/runtime/wasm/fs.wat @@ -21,12 +21,14 @@ (import "bindings" "mkdir" (func $mkdir (param anyref) (param i32))) (import "bindings" "rmdir" (func $rmdir (param anyref))) (import "bindings" "unlink" (func $unlink (param anyref))) - (import "bindings" "readdir" - (func $readdir (param anyref) (result (ref extern)))) + (import "bindings" "read_dir" + (func $read_dir (param anyref) (result (ref extern)))) (import "bindings" "file_exists" (func $file_exists (param anyref) (result (ref eq)))) (import "bindings" "is_directory" (func $is_directory (param anyref) (result (ref eq)))) + (import "bindings" "is_file" + (func $is_file (param anyref) (result (ref eq)))) (import "bindings" "rename" (func $rename (param anyref) (param anyref))) (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) @@ -47,7 +49,12 @@ (func (export "caml_sys_getcwd") (param (ref eq)) (result (ref eq)) - (return_call $caml_string_of_jsstring (call $wrap (call $getcwd)))) + (try (result (ref eq)) + (do + (call $caml_string_of_jsstring (call $wrap (call $getcwd)))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)) + (ref.i31 (i32.const 0))))) (func (export "caml_sys_chdir") (param $name (ref eq)) (result (ref eq)) @@ -76,7 +83,7 @@ (do (return (call $caml_js_to_string_array - (call $readdir + (call $read_dir (call $unwrap (call $caml_jsstring_of_string (local.get $name))))))) (catch $javascript_exception @@ -137,8 +144,6 @@ (local.get $msg) (local.get $len) (i32.const 0) (i32.const 27)) (call $caml_raise_sys_error (local.get $msg))) - (data $caml_read_file_content "caml_read_file_content") - (func (export "caml_read_file_content") (param (ref eq)) (result (ref eq)) (call $caml_raise_no_such_file (local.get 0)) @@ -147,8 +152,6 @@ (func (export "caml_fs_init") (result (ref eq)) (ref.i31 (i32.const 0))) - (data $caml_sys_is_directory "caml_sys_is_directory") - (func (export "caml_sys_is_directory") (param $name (ref eq)) (result (ref eq)) (try @@ -160,4 +163,16 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (return (ref.i31 (i32.const 0)))))) + + (func (export "caml_sys_is_regular_file") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (return + (call $is_file + (call $unwrap + (call $caml_jsstring_of_string (local.get $name)))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)) + (return (ref.i31 (i32.const 0)))))) ) diff --git a/runtime/wasm/io.wat b/runtime/wasm/io.wat index fc07d84d02..3a4b2086e1 100644 --- a/runtime/wasm/io.wat +++ b/runtime/wasm/io.wat @@ -315,6 +315,18 @@ (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 1))) + (func (export "caml_channel_descriptor") + (param $ch (ref eq)) (result (ref eq)) + (local $fd i32) + (local.set $fd + (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch)))) + (if (i32.eq (local.get $fd) (i32.const -1)) + (then + (call $caml_raise_sys_error + (array.new_data $bytes $bad_file_descriptor + (i32.const 0) (i32.const 19))))) + (ref.i31 (local.get $fd))) + (func (export "caml_ml_close_channel") (param (ref eq)) (result (ref eq)) (local $ch (ref $channel)) @@ -605,6 +617,17 @@ (struct.get $channel $fd (local.get $ch)))) (i64.extend_i32_s (struct.get $channel $curr (local.get $ch)))))) +(;ZZZ + (func $check_valid_offset + (param $fd i32) (param $offset i64) (param $prev_offset i64) + (if (i32.or (i32.lt_s (local.get $offset (i64.const 0))) + (i32.gt_s (local.get $offset) + (call $file_size (local.get $fd))))) + (then + ;;; + ))) +;) + (func $caml_seek_in (param $ch (ref $channel)) (param $dest i64) (result (ref eq)) (local $fd i32) (local $offset i64) diff --git a/runtime/wasm/runtime.js b/runtime/wasm/runtime.js index 1de4458c2c..087cc66a1c 100644 --- a/runtime/wasm/runtime.js +++ b/runtime/wasm/runtime.js @@ -70,6 +70,10 @@ const fs_cst = fs?.constants; + const access_flags = fs + ? [fs_cst.R_OK, fs_cst.W_OK, fs_cst.X_OK, fs_cst.F_OK] + : []; + const open_flags = fs ? [ fs_cst.O_RDONLY, @@ -374,6 +378,15 @@ return pad ? " " + s : s; }, gettimeofday: () => new Date().getTime() / 1000, + times: () => { + if (globalThis.process?.cpuUsage) { + var t = globalThis.process.cpuUsage(); + return caml_alloc_times(t.user / 1e6, t.system / 1e6); + } else { + var t = performance.now() / 1000; + return call_alloc_times(t, t); + } + }, gmtime: (t) => { var d = new Date(t * 1000); var d_num = d.getTime(); @@ -417,6 +430,11 @@ mktime: (year, month, day, h, m, s) => new Date(year, month, day, h, m, s).getTime(), random_seed: () => crypto.getRandomValues(new Int32Array(12)), + access: (p, flags) => + fs.accessSync( + p, + access_flags.reduce((f, v, i) => (flags & (1 << i) ? f | v : f), 0), + ), open: (p, flags, perm) => fs.openSync( p, @@ -432,6 +450,7 @@ ), l), read: (fd, b, o, l, p) => fs.readSync(fd, b, o, l, p), + fsync: (fd) => fs.fsyncSync(fd), file_size: (fd) => fs.fstatSync(fd, { bigint: true }).size, register_channel, unregister_channel, @@ -454,13 +473,25 @@ chdir: (x) => process.chdir(x), mkdir: (p, m) => fs.mkdirSync(p, m), rmdir: (p) => fs.rmdirSync(p), + link: (d, s) => fs.linkSync(d, s), + symlink: (t, p, kind) => fs.symlinkSync(t, p, [null, "file", "dir"][kind]), + readlink: (p) => fs.readlinkSync(p), unlink: (p) => fs.unlinkSync(p), - readdir: (p) => fs.readdirSync(p), + read_dir: (p) => fs.readdirSync(p), + opendir: (p) => fs.opendirSync(p), + readdir: (d) => { + var n = d.readSync()?.name; + return n === undefined ? null : n; + }, + closedir: (d) => d.closeSync(), stat: (p, l) => alloc_stat(fs.statSync(p), l), lstat: (p, l) => alloc_stat(fs.lstatSync(p), l), fstat: (fd, l) => alloc_stat(fs.fstatSync(fd), l), + chmod: (p, perms) => fs.chmodSync(p, perms), + fchmod: (p, perms) => fs.fchmodSync(p, perms), file_exists: (p) => +fs.existsSync(p), is_directory: (p) => +fs.lstatSync(p).isDirectory(), + is_file: (p) => +fs.lstatSync(p).isFile(), utimes: (p, a, m) => fs.utimesSync(p, a, m), truncate: (p, l) => fs.truncateSync(p, l), ftruncate: (fd, l) => fs.ftruncateSync(fd, l), @@ -583,6 +614,7 @@ var { caml_callback, + caml_alloc_times, caml_alloc_tm, caml_alloc_stat, caml_start_fiber, diff --git a/runtime/wasm/sys.wat b/runtime/wasm/sys.wat index 6cfa7817e1..feff58e716 100644 --- a/runtime/wasm/sys.wat +++ b/runtime/wasm/sys.wat @@ -37,6 +37,8 @@ (import "fail" "caml_raise_not_found" (func $caml_raise_not_found)) (import "bindings" "argv" (func $argv (result (ref extern)))) (import "bindings" "on_windows" (global $on_windows i32)) + (import "bindings" "isatty" + (func $isatty (param (ref eq)) (result (ref eq)))) (import "bindings" "system" (func $system (param anyref) (result (ref eq)))) (import "bindings" "getenv" (func $getenv (param anyref) (result anyref))) (import "bindings" "time" (func $time (result f64))) @@ -49,6 +51,8 @@ (import "jsstring" "jsstring_test" (func $jsstring_test (param anyref) (result i32))) (import "bindings" "exit" (func $exit (param (ref eq)))) + (import "io" "caml_channel_descriptor" + (func $caml_channel_descriptor (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -165,8 +169,8 @@ (ref.i31 (i32.const 0)))) (func (export "caml_sys_isatty") - (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.const 0))) + (param $ch (ref eq)) (result (ref eq)) + (return_call $isatty (call $caml_channel_descriptor (local.get $ch)))) (func (export "caml_runtime_variant") (param (ref eq)) (result (ref eq)) (array.new_fixed $bytes 0)) diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index 0e5fbf7535..867f22abde 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -17,6 +17,7 @@ (module (import "bindings" "gettimeofday" (func $gettimeofday (result f64))) + (import "bindings" "times" (func $times (result (ref eq)))) (import "bindings" "gmtime" (func $gmtime (param f64) (result (ref eq)))) (import "bindings" "localtime" (func $localtime (param f64) (result (ref eq)))) @@ -29,12 +30,26 @@ (import "bindings" "lstat" (func $lstat (param anyref i32) (result (ref eq)))) (import "bindings" "fstat" (func $fstat (param (ref eq) i32) (result (ref eq)))) + (import "bindings" "chmod" (func $chmod (param anyref (ref eq)))) + (import "bindings" "fchmod" (func $fchmod (param (ref eq) (ref eq)))) (import "bindings" "rename" (func $rename (param anyref) (param anyref))) + (import "bindings" "getcwd" (func $getcwd (result anyref))) + (import "bindings" "chdir" (func $chdir (param anyref))) + (import "bindings" "mkdir" (func $mkdir (param anyref) (param i32))) + (import "bindings" "opendir" (func $opendir (param anyref) (result anyref))) + (import "bindings" "readdir" (func $readdir (param anyref) (result anyref))) + (import "bindings" "closedir" (func $closedir (param anyref))) + (import "bindings" "rmdir" (func $rmdir (param anyref))) + (import "bindings" "link" (func $link (param anyref anyref))) + (import "bindings" "symlink" (func $symlink (param anyref anyref i32))) + (import "bindings" "readlink" (func $readlink (param anyref) (result anyref))) + (import "bindings" "unlink" (func $unlink (param anyref))) (import "bindings" "truncate" (func $truncate (param anyref (ref eq)))) (import "bindings" "truncate" (func $truncate_64 (param anyref f64))) (import "bindings" "ftruncate" (func $ftruncate (param (ref eq) (ref eq)))) (import "bindings" "ftruncate" (func $ftruncate_64 (param (ref eq) f64))) (import "bindings" "file_size" (func $file_size (param i32) (result i64))) + (import "bindings" "access" (func $access (param anyref) (param i32))) (import "bindings" "open" (func $open (param anyref) (param i32) (param i32) (result i32))) (import "bindings" "write" @@ -45,10 +60,13 @@ (func $read (param i32 (ref extern) i32 i32 i64) (result i32))) (import "bindings" "read" (func $read' (param i32 (ref extern) i32 i32 nullexternref) (result i32))) + (import "bindings" "fsync" (func $fsync (param (ref eq)))) (import "bindings" "close" (func $close (param (ref eq)))) (import "bindings" "isatty" (func $isatty (param (ref eq)) (result (ref eq)))) (import "js" "unix_error" (global $unix_error_js (ref any))) + (import "js" "caml_strerror" + (func $caml_strerror (param i32) (result (ref any)))) (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) (import "jslib" "caml_js_meth_call" @@ -67,10 +85,12 @@ (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) + (import "fail" "caml_raise_end_of_file" (func $caml_raise_end_of_file)) (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_raise_not_found" (func $caml_raise_not_found)) (import "io" "convert_flag_list" - (func $convert_flag_list (param (ref $open_flags) (ref eq)) (result i32))) + (func $convert_flag_list (param (ref $flags) (ref eq)) (result i32))) (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) (import "io" "initialize_fd_offset" (func $initialize_fd_offset (param i32 i64))) @@ -100,6 +120,7 @@ (type $bytes (array (mut i8))) (type $block (array (mut (ref eq)))) (type $float (struct (field f64))) + (type $float_array (array (mut f64))) (type $js (struct (field anyref))) (type $fd_offset @@ -199,11 +220,36 @@ (call $caml_js_get (local.get $exn) (array.new_data $bytes $path (i32.const 0) (i32.const 4))))))) - (export "caml_unix_gettimeofday" (func $unix_gettimeofday)) - (func $unix_gettimeofday (export "unix_gettimeofday") + (func (export "unix_error_message") (export "caml_unix_error_message") + (param $err (ref eq)) (result (ref eq)) + (local $errno i32) + (local.set $errno + (if (result i32) (ref.test (ref i31) (local.get $err)) + (then + (i31.get_u (ref.cast (ref i31) (local.get $err)))) + (else + (i32.sub (i32.const 0) + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $err)) + (i32.const 1)))))))) + (return_call $caml_string_of_jsstring + (call $wrap (call $caml_strerror (local.get $errno))))) + + (func (export "unix_gettimeofday") (export "caml_unix_gettimeofday") (param (ref eq)) (result (ref eq)) (struct.new $float (call $gettimeofday))) + (func (export "caml_alloc_times") + (param $u f64) (param $s f64) (result (ref eq)) + (array.new_fixed $float_array 4 + (local.get $u) (local.get $s) (f64.const 0) (f64.const 0))) + + (func (export "unix_times") (export "caml_unix_times") + (param (ref eq)) (result (ref eq)) + (return_call $times)) + (func (export "caml_alloc_tm") (param $sec i32) (param $min i32) (param $hour i32) (param $mday i32) (param $mon i32) (param $year i32) (param $wday i32) (param $yday i32) @@ -219,23 +265,22 @@ (ref.i31 (local.get $yday)) (ref.i31 (local.get $isdst)))) - (export "caml_unix_gmtime" (func $unix_gmtime)) - (func $unix_gmtime (export "unix_gmtime") (param (ref eq)) (result (ref eq)) + (func $unix_gmtime (export "unix_gmtime") (export "caml_unix_gmtime") + (param (ref eq)) (result (ref eq)) (call $gmtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) - (export "caml_unix_localtime" (func $unix_localtime)) - (func $unix_localtime (export "unix_localtime") + (func $unix_localtime (export "unix_localtime") (export "caml_unix_localtime") (param (ref eq)) (result (ref eq)) (call $localtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) - (export "caml_unix_time" (func $unix_time)) - (func $unix_time (export "unix_time") (param (ref eq)) (result (ref eq)) + (func $unix_time (export "unix_time") (export "caml_unix_time") + (param (ref eq)) (result (ref eq)) (struct.new $float (f64.floor (call $gettimeofday)))) - (export "caml_unix_mktime" (func $unix_mktime)) - (func $unix_mktime (export "unix_mktime") (param (ref eq)) (result (ref eq)) + (func $unix_mktime (export "unix_mktime") (export "caml_unix_mktime") + (param (ref eq)) (result (ref eq)) (local $tm (ref $block)) (local $t f64) (local.set $tm (ref.cast (ref $block) (local.get 0))) (local.set $t @@ -374,6 +419,26 @@ (call $caml_unix_error (pop externref) (ref.null eq)) (ref.i31 (i32.const 0))))) + (func (export "unix_chmod") (export "caml_unix_chmod") + (param $path (ref eq)) (param $perms (ref eq)) (result (ref eq)) + (try + (do + (call $chmod + (call $unwrap (call $caml_jsstring_of_string (local.get $path))) + (local.get $perms))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_fchmod") (export "caml_unix_fchmod") + (param $fd (ref eq)) (param $perms (ref eq)) (result (ref eq)) + (try + (do + (call $fchmod (local.get $fd) (local.get $perms))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + (func (export "unix_rename") (export "caml_unix_rename") (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) (try @@ -385,6 +450,214 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) + (func (export "unix_getcwd") (export "caml_unix_getcwd") + (param (ref eq)) (result (ref eq)) + (try (result (ref eq)) + (do + (call $caml_string_of_jsstring (call $wrap (call $getcwd)))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)) + (ref.i31 (i32.const 0))))) + + (func (export "unix_chdir") (export "caml_unix_chdir") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (call $chdir + (call $unwrap (call $caml_jsstring_of_string (local.get $name))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_mkdir") (export "caml_unix_mkdir") + (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) + (try + (do + (call $mkdir + (call $unwrap (call $caml_jsstring_of_string (local.get $name))) + (i31.get_u (ref.cast (ref i31) (local.get $perm))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func $unix_opendir (export "unix_opendir") (export "caml_unix_opendir") + (param $name (ref eq)) (result (ref eq)) + (try (result (ref eq)) + (do + (call $wrap + (call $opendir + (call $unwrap + (call $caml_jsstring_of_string (local.get $name)))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)) + (ref.i31 (i32.const 0))))) + + (func $throw_ebadf (param $cmd (ref eq)) + (throw $ocaml_exception + (array.new_fixed $block 5 + (ref.i31 (i32.const 0)) + (call $get_unix_error_exn) + (ref.i31 (i32.const 3)) ;; EBADF + (local.get $cmd) + (global.get $no_arg)))) + + (data $readdir "readdir") + + (func $readdir_helper (param $dir (ref eq)) (result (ref eq)) + (block $end + (return + (try (result (ref eq)) + (do + (call $caml_string_of_jsstring + (call $wrap + (br_on_null $end + (call $readdir (call $unwrap (local.get $dir))))))) + (catch $javascript_exception + (drop (pop externref)) + (call $throw_ebadf + (array.new_data $bytes $readdir + (i32.const 0) (i32.const 7))) + (ref.i31 (i32.const 0)))))) + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0))) + + (data $closedir "closedir") + + (func $unix_closedir (export "unix_closedir") (export "caml_unix_closedir") + (export "win_findclose") (export "caml_unix_findclose") + (param $dir (ref eq)) (result (ref eq)) + (try + (do + (call $closedir (call $unwrap (local.get $dir)))) + (catch $javascript_exception + (drop (pop externref)) + (call $throw_ebadf + (array.new_data $bytes $closedir (i32.const 0) (i32.const 8))))) + (ref.i31 (i32.const 0))) + + (func (export "unix_readdir") (export "caml_unix_readdir") + (param $dir (ref eq)) (result (ref eq)) + (block $return (result (ref eq)) + (br_on_non_null $return (call $readdir_helper (local.get $dir))) + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0)))) + + (func $win_find_next (export "win_findnext") (export "caml_unix_findnext") + (param $dir (ref eq)) (result (ref eq)) + (block $return (result (ref eq)) + (br_on_non_null $return (call $readdir_helper (local.get $dir))) + (drop (call $unix_closedir (local.get $dir))) + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0)))) + + (func (export "win_findfirst") (export "caml_unix_findfirst") + (param $vpath (ref eq)) (result (ref eq)) + (local $dir (ref eq)) (local $p (ref $bytes)) (local $p' (ref $bytes)) + (local $len i32) + (local.set $p (ref.cast (ref $bytes) (local.get $vpath))) + (local.set $len (i32.sub (array.len (local.get $p)) (i32.const 3))) + (local.set $p' (array.new $bytes (i32.const 0) (local.get $len))) + (array.copy $bytes $bytes + (local.get $p') (i32.const 0) + (local.get $p) (i32.const 0) + (local.get $len)) + (local.set $dir (call $unix_opendir (local.get $p'))) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (call $win_find_next (local.get $dir)) + (local.get $dir))) + + (data $rewinddir_not_implemented "rewinddir not implemented") + + (func (export "unix_rewinddir") (export "caml_unix_rewinddir") + (param (ref eq)) (result (ref eq)) + (call $caml_invalid_argument + (array.new_data $bytes $rewinddir_not_implemented + (i32.const 0) (i32.const 25))) + (ref.i31 (i32.const 0))) + + (func (export "unix_unlink") (export "caml_unix_unlink") + (param $p (ref eq)) (result (ref eq)) + (try + (do + (call $unlink + (call $unwrap (call $caml_jsstring_of_string (local.get $p))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_rmdir") (export "caml_unix_rmdir") + (param $p (ref eq)) (result (ref eq)) + (try + (do + (call $rmdir + (call $unwrap (call $caml_jsstring_of_string (local.get $p))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (data $link "link") + + (func (export "unix_link") (export "caml_unix_link") + (param $follow (ref eq)) (param $d (ref eq)) (param $s (ref eq)) + (result (ref eq)) + (if (ref.test (ref $block) (local.get $follow)) + (then + (throw $ocaml_exception + (array.new_fixed $block 5 + (ref.i31 (i32.const 0)) + (call $get_unix_error_exn) + (ref.i31 (i32.const 25)) ;; ENOSYS + (array.new_data $bytes $link (i32.const 0) (i32.const 4)) + (global.get $no_arg))))) + (try + (do + (call $link + (call $unwrap (call $caml_jsstring_of_string (local.get $d))) + (call $unwrap (call $caml_jsstring_of_string (local.get $s))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_has_symlink") (export "caml_unix_has_symlink") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 1))) + + (func (export "unix_symlink") (export "caml_unix_symlink") + (param $to_dir (ref eq)) (param $t (ref eq)) (param $p (ref eq)) + (result (ref eq)) + (local $kind i32) + (if (ref.test (ref $block) (local.get $to_dir)) + (then + (local.set $kind + (i32.add (i32.const 1) + (i31.get_s + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $to_dir)) + (i32.const 0)))))))) + (try + (do + (call $symlink + (call $unwrap (call $caml_jsstring_of_string (local.get $t))) + (call $unwrap (call $caml_jsstring_of_string (local.get $p))) + (local.get $kind))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (func (export "unix_readlink") (export "caml_unix_readlink") + (param $path (ref eq)) (result (ref eq)) + (try + (do + (return_call $caml_string_of_jsstring + (call $wrap + (call $readlink + (call $unwrap + (call $caml_jsstring_of_string (local.get $path))))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + (func (export "unix_truncate") (export "caml_unix_truncate") (param $path (ref eq)) (param $len (ref eq)) (result (ref eq)) @@ -460,7 +733,26 @@ (local.get $len)))) (ref.i31 (i32.const 0))) - (type $open_flags (array i8)) + (global $access_flags (ref $flags) + (array.new_fixed $flags 4 + (i32.const 1) (i32.const 2) (i32.const 4) (i32.const 8))) + + (func (export "unix_access") (export "caml_unix_access") + (param $path (ref eq)) (param $vflags (ref eq)) (result (ref eq)) + (local $flags i32) + (local.set $flags + (call $convert_flag_list + (global.get $access_flags) (local.get $vflags))) + (try + (do + (call $access + (call $unwrap (call $caml_jsstring_of_string (local.get $path))) + (local.get $flags))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) + + (type $flags (array i8)) ;; 1 O_RDONLY ;; 2 O_WRONLY ;; 4 O_RDWR @@ -472,8 +764,8 @@ ;; 256 O_NOCTTY ;; 512 O_DSYNC ;; 1024 O_SYNC - (global $unix_open_flags (ref $open_flags) - (array.new_fixed $open_flags 15 + (global $unix_open_flags (ref $flags) + (array.new_fixed $flags 15 (i32.const 1) (i32.const 2) (i32.const 4) (i32.const 128) (i32.const 8) (i32.const 16) (i32.const 32) (i32.const 64) (i32.const 256) (i32.const 512) (i32.const 1024) (i32.const 0) @@ -566,6 +858,51 @@ (br $loop)))) (ref.i31 (local.get $n))) + (func (export "unix_single_write") (export "caml_unix_single_write") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $fd i32) (local $s (ref $bytes)) (local $buf (ref extern)) + (local $pos i32) (local $len i32) (local $numbytes i32) + (local $written i32) (local $n i32) + (local $fd_offset (ref $fd_offset)) + (local $offset i64) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $s (ref.cast (ref $bytes) (local.get $vbuf))) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (local.set $buf (call $get_io_buffer)) + (local.set $fd_offset (call $get_fd_offset (local.get $fd))) + (local.set $offset + (struct.get $fd_offset $offset (local.get $fd_offset))) + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $ta_blit_from_bytes + (local.get $s) (local.get $pos) + (local.get $buf) (i32.const 0) (local.get $numbytes)) + (try + (do + (local.set $n + (if (result i32) + (struct.get $fd_offset $seeked (local.get $fd_offset)) + (then + (call $write (local.get $fd) (local.get $buf) + (i32.const 0) (local.get $numbytes) + (local.get $offset))) + (else + (call $write' (local.get $fd) (local.get $buf) + (i32.const 0) (local.get $numbytes) + (ref.null extern)))))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (local.set $offset + (i64.add (local.get $offset) (i64.extend_i32_u (local.get $n)))) + (struct.set $fd_offset $offset + (local.get $fd_offset) (local.get $offset)))) + (ref.i31 (local.get $n))) + (func (export "unix_read") (export "caml_unix_read") (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) (result (ref eq)) @@ -596,7 +933,7 @@ (call $ta_blit_to_bytes (local.get $buf) (i32.const 0) (ref.cast (ref $bytes) (local.get $vbuf)) (local.get $pos) - (local.get $len)) + (local.get $n)) (ref.i31 (local.get $n))) (func (export "unix_write_bigarray") (export "caml_unix_write_bigarray") @@ -682,14 +1019,14 @@ (func $lseek (param $vfd (ref eq)) (param $offset i64) (param $cmd (ref eq)) - (result (ref eq)) + (result i64) (local $fd i32) (local $fd_offset (ref $fd_offset)) (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) (local.set $fd_offset (block $non_null (result (ref $fd_offset)) (br_on_non_null $non_null (call $get_fd_offset_unchecked (local.get $fd))) - (throw $ocaml_exception (call $lseek_exn (i32.const 9))))) ;; EBADF + (throw $ocaml_exception (call $lseek_exn (i32.const 3))))) ;; EBADF (if (ref.eq (local.get $cmd) (ref.i31 (i32.const 1))) (then (local.set $offset @@ -706,23 +1043,36 @@ (call $lseek_exn (i32.const 12))))) ;; EINVAL (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $offset)) (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) - (ref.i31 (i32.const 0))) + (local.get $offset)) (func (export "unix_lseek") (export "caml_unix_lseek") (param $fd (ref eq)) (param $ofs (ref eq)) (param $cmd (ref eq)) (result (ref eq)) - (return_call $lseek - (local.get $fd) - (i64.extend_i32_s (i31.get_s (ref.cast (ref i31) (local.get $ofs)))) - (local.get $cmd))) + (ref.i31 + (i32.wrap_i64 + (call $lseek + (local.get $fd) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $ofs)))) + (local.get $cmd))))) (func (export "unix_lseek_64") (export "caml_unix_lseek_64") (param $fd (ref eq)) (param $ofs (ref eq)) (param $cmd (ref eq)) (result (ref eq)) - (return_call $lseek - (local.get $fd) - (call $Int64_val (local.get $ofs)) - (local.get $cmd))) + (return_call $caml_copy_int64 + (call $lseek + (local.get $fd) + (call $Int64_val (local.get $ofs)) + (local.get $cmd)))) + + (func (export "unix_fsync") (export "caml_unix_fsync") + (param $fd (ref eq)) (result (ref eq)) + (try + (do + (call $fsync (local.get $fd))) + (catch $javascript_exception + (call $caml_unix_error (pop externref) (ref.null eq)))) + (ref.i31 (i32.const 0))) (data $out_channel_of_descr "out_channel_of_descr") (data $in_channel_of_descr "in_channel_of_descr") @@ -789,15 +1139,30 @@ (export "unix_isatty" (func $isatty)) (export "caml_unix_isatty" (func $isatty)) - (export "caml_unix_inet_addr_of_string" (func $unix_inet_addr_of_string)) - (func $unix_inet_addr_of_string (export "unix_inet_addr_of_string") + (func (export "unix_getuid") (export "caml_unix_getuid") + (export "unix_geteuid") (export "caml_unix_geteuid") + (export "unix_getgid") (export "caml_unix_getgid") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 1))) + + (func (export "unix_getpwnam") (export "caml_unix_getpwnam") + (export "unix_getpwuid") (export "caml_unix_getpwuid") + (export "unix_getgrnam") (export "caml_unix_getgrnam") + (export "unix_getgruid") (export "caml_unix_getgruid") (param (ref eq)) (result (ref eq)) + (call $caml_raise_not_found) (ref.i31 (i32.const 0))) - (export "caml_unix_filedescr_of_fd" (func $unix_filedescr_of_fd)) - (func $unix_filedescr_of_fd (export "unix_filedescr_of_fd") + + (func (export "unix_inet_addr_of_string") + (export "caml_unix_inet_addr_of_string") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "win_handle_fd") (export "caml_unix_filedescr_of_fd") (param (ref eq)) (result (ref eq)) (local.get 0)) - (func $unix_cleanup (export "caml_unix_cleanup") + + (func (export "win_cleanup") (export "caml_unix_cleanup") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) )