add `filesystem-change-evt'

The `filesystem-change-evt' function takes a path to a file
or directory and returns an event that becomes ready when
the file or directory changes (conservatively, so false
positives are possible).

These events are supported on Linux, Mac OS X and other BSD
variants with kqueue(), and Windows.

pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl

@@ -473,6 +473,73 @@ On Windows, an element of the result list may start with
 Returns a list of all current root directories. Obtaining this list
 can be particularly slow on Windows.}
 
+@;------------------------------------------------------------------------
+@section[#:tag "filesystem-change"]{Detecting Filesystem Changes}
+
+Many operating systems provide notifications for filesystem changes,
+and those notifications are reflected in Racket by @tech{filesystem
+change events}.
+
+@defproc[(filesystem-change-evt? [v any/c]) boolean?]{
+
+Returns @racket[#f] if @racket[v] is a @tech{filesystem change
+event}, @racket[#f] otherwise.}
+
+
+@defproc*[([(filesystem-change-evt [path path-string?])
+            filesystem-change-evt?]
+           [(filesystem-change-evt [path path-string?]
+                                   [failure-thunk (-> any)])
+            any])]{
+
+Creates a @deftech{filesystem change event}, which is
+@tech{synchronizable event} that becomes @tech{ready for
+synchronization} after a change to @racket[path]:
+
+@itemlist[
+
+ @item{If @racket[path] refers to a file, the event becomes
+       @tech{ready for synchronization} when the file's content or
+       attributes change, or when the file is deleted.}
+
+ @item{If @racket[path] refers to a directory, the event becomes
+       @tech{ready for synchronization} if a file or subdirectory is
+       added, renamed, or removed within the directory.}
+
+]
+
+The event also becomes @tech{ready for synchronization} if
+it is passed to @racket[filesystem-change-evt-cancel].
+
+Finally, depending on the precision of information available from the
+operating system, the event may become @tech{ready for
+synchronization} under other circumstances. For example, on
+Windows, an event for a file becomes ready when any file changes
+within in the same directory as the file.
+
+If the current platform does not support filesystem-change
+notifications, then the @exnraise[exn:fail:unsupported] if
+@racket[failure-thunk] is not provided, or @racket[failure-thunk] is
+called in tail position if provided. Similarly, if there is any
+operating-system error when creating the event (such as a non-existent
+file), then the @exnraise[exn:fail:filesystem] or @racket[failure-thunk]
+is called.
+
+A @tech{filesystem change event} is placed under the management of the
+@tech{current custodian} when it is created. If the @tech{custodian}
+is shut down, @racket[filesystem-change-evt-cancel] is applied to the
+event.}
+
+
+@defproc[(filesystem-change-evt-cancel [evt filesystem-change-evt?])
+         void?]{
+
+Causes @racket[evt] to become immediately @tech{ready for
+synchronization}, whether it was ready or before not, and releases and
+resources (at the operating system level) for tracking filesystem
+changes.}
+
+
 @;------------------------------------------------------------------------
 @section[#:tag "runtime-path"]{Declaring Paths Needed at Run Time}
 

pkgs/racket-pkgs/racket-test/tests/racket/file.rktl

@@ -1378,6 +1378,93 @@
 		 '(close-input-port r2))))
   (tcp-close l))
 
+;;----------------------------------------------------------------------
+;; Filesystem-change events
+
+(test #f filesystem-change-evt? 'evt)
+
+(let ([dir (make-temporary-file "change~a" 'directory)])
+  (define known-file-supported?
+    (case (system-type)
+      [(macosx) #t]
+      [else #f]))
+  (define known-supported?
+    (or known-file-supported?
+        (case (system-type)
+          [(windows) #t]
+          [else #f])))
+  (define (check-supported evt file?)
+    (when (if file?
+              known-file-supported?
+              known-supported?)
+      (test #t filesystem-change-evt? evt)))
+
+  (define (check f1-name f2-name as-file? known-x-supported?)
+    (printf "checking ~s, ~s as ~a\n" f1-name f2-name (if as-file? "file" "dir"))
+    (define f1 (build-path dir f1-name))
+    (define f2 (build-path dir f2-name))
+
+    (define dir-e (filesystem-change-evt dir (lambda () #f)))
+    (check-supported dir-e #f)
+    (if as-file?
+        (call-with-output-file* f1 (lambda (o) (fprintf o "1\n")))
+        (make-directory f1))
+    (when dir-e
+      (test dir-e sync dir-e)
+      (test dir-e sync dir-e))
+    (if as-file?
+        (call-with-output-file* f2 (lambda (o) (fprintf o "2\n")))
+        (make-directory f2))
+
+    (define f1-e (filesystem-change-evt f1 (lambda () #f)))
+    (define f2-e (filesystem-change-evt f2 (lambda () #f)))
+    (check-supported f1-e #t)
+    (check-supported f2-e #t)
+    
+    (when f1-e
+      (test #f sync/timeout 0 f1-e)
+      (test #f sync/timeout 0 f2-e)
+      
+      (call-with-output-file (if as-file?
+                                 f1
+                                 (build-path f1 "x"))
+        #:exists 'append 
+        (lambda (o) (newline o)))
+      (test f1-e sync f1-e)
+      (when known-x-supported?
+        (test #f sync/timeout 0 f2-e))
+
+      (call-with-output-file (if as-file?
+                                 f2
+                                 (build-path f2 "y"))
+        #:exists 'append 
+        (lambda (o) (newline o)))
+      (test f2-e sync/timeout 0 f2-e)
+      (test f2-e sync f2-e)
+      (test f1-e sync f1-e)
+
+      (define f1-e2 (filesystem-change-evt f1 (lambda () #f)))
+      (when known-x-supported?
+        (test #f sync/timeout 0 f1-e2))
+      (test f1-e sync/timeout 0 f1-e)
+      (test f1-e sync f1-e)
+
+      (filesystem-change-evt-cancel f1-e2)
+      (test f1-e2 sync/timeout 0 f1-e2)
+
+      (define cust (make-custodian))
+      (define f1-e3 (parameterize ([current-custodian cust])
+                      (filesystem-change-evt f2 (lambda () #f))))
+      (when known-x-supported?
+        (test #f sync/timeout 0 f1-e3))
+      (custodian-shutdown-all cust)
+      (test f1-e3 sync/timeout 0 f1-e3)))
+
+  (check "f1" "f2" #t known-file-supported?)
+  (check "f1d" "f2d" #f known-supported?)
+
+  (delete-directory/files dir))
+
 ;;----------------------------------------------------------------------
 ;; TCP
 

racket/lib/collects/racket/HISTORY.txt

@@ -1,3 +1,7 @@
+Version 5.3.900.4
+Added filesystem-change-evt, filesystem-change-evt?, and
+ filesystem-change-evt-cancel
+
 Version 5.3.900.2
 Changed link-file handling to separate "user" and "shared" modes;
  removed 'links-file mode for find-system-path, PLTLINKSFILE

racket/src/configure

@@ -4080,6 +4080,7 @@ case "$host_os" in
     DYN_CFLAGS="-fPIC"
     try_poll_syscall=yes
     try_epoll_syscall=yes
+    try_inotify_syscall=yes
     case "$host_cpu" in
       #Required for CentOS 4.6
       x86_64)
@@ -5473,6 +5474,61 @@ _ACEOF
   fi
 fi
 
+if test "${try_inotify_syscall}" = "yes" ; then
+   msg="for inotify"
+  { echo "$as_me:$LINENO: checking $msg" >&5
+echo $ECHO_N "checking $msg... $ECHO_C" >&6; }
+  cat >conftest.$ac_ext <<_ACEOF
+  #include <sys/inotify.h>
+    int main() {
+      int fd;
+      int wd;
+      fd = inotify_init();
+      wd = inotify_add_watch(fd, "/tmp",
+                             (IN_CREATE | IN_DELETE | IN_DELETE_SELF
+                              | IN_MODIFY | IN_MOVE_SELF | IN_MOVED_TO));
+      return 0;
+    }
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+  *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+  (eval "$ac_link") 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } && {
+	 test -z "$ac_c_werror_flag" ||
+	 test ! -s conftest.err
+       } && test -s conftest$ac_exeext &&
+       $as_test_x conftest$ac_exeext; then
+  use_inotify=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+	use_inotify=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+      conftest$ac_exeext conftest.$ac_ext
+  { echo "$as_me:$LINENO: result: $use_inotify" >&5
+echo "${ECHO_T}$use_inotify" >&6; }
+  if test "${use_inotify}" = "yes" ; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_INOTIFY_SYSCALL 1
+_ACEOF
+
+  fi
+fi
+
 if test "${try_kqueue_syscall}" = "yes" ; then
    msg="for kqueue"
   { echo "$as_me:$LINENO: checking $msg" >&5

racket/src/racket/configure.ac

@@ -579,6 +579,7 @@ case "$host_os" in
     DYN_CFLAGS="-fPIC"
     try_poll_syscall=yes
     try_epoll_syscall=yes
+    try_inotify_syscall=yes
     case "$host_cpu" in
       #Required for CentOS 4.6
       x86_64)
@@ -964,6 +965,26 @@ if test "${try_epoll_syscall}" = "yes" ; then
   fi
 fi
 
+if test "${try_inotify_syscall}" = "yes" ; then
+  [ msg="for inotify" ]
+  AC_MSG_CHECKING($msg)
+  AC_LINK_IFELSE(
+  [  #include <sys/inotify.h> ]
+    int main() {
+      int fd;
+      int wd;
+      fd = inotify_init();
+      wd = inotify_add_watch(fd, "/tmp", 
+                             (IN_CREATE | IN_DELETE | IN_DELETE_SELF
+                              | IN_MODIFY | IN_MOVE_SELF | IN_MOVED_TO));
+      return 0;
+    }, use_inotify=yes, use_inotify=no)
+  AC_MSG_RESULT($use_inotify)
+  if test "${use_inotify}" = "yes" ; then
+     AC_DEFINE(HAVE_INOTIFY_SYSCALL,1,[Have inotify])
+  fi
+fi
+
 if test "${try_kqueue_syscall}" = "yes" ; then
   [ msg="for kqueue" ]
   AC_MSG_CHECKING($msg)

racket/src/racket/include/scheme.h

@@ -2105,6 +2105,8 @@ extern Scheme_Extension_Table *scheme_extension_table;
 #define MZFD_CHECK_READ   3
 #define MZFD_CHECK_WRITE  4
 #define MZFD_REMOVE       5
+#define MZFD_CREATE_VNODE 6
+#define MZFD_CHECK_VNODE  7
 
 /*========================================================================*/
 

racket/src/racket/mzconfig.h.in

@@ -56,9 +56,10 @@ typedef unsigned long uintptr_t;
 /* Whether pthread_rwlock is available. */
 #undef HAVE_PTHREAD_RWLOCK
 
-/* When poll(), epoll(), and/or kqueue() is available: */
+/* When poll(), epoll(), kqueue(), etc. is available: */
 #undef HAVE_POLL_SYSCALL
 #undef HAVE_EPOLL_SYSCALL
+#undef HAVE_INOTIFY_SYSCALL
 #undef HAVE_KQUEUE_SYSCALL
 
 /* When mmap() and mprotect() are available: */

racket/src/racket/src/mzmark_port.inc

@@ -201,3 +201,28 @@ static int mark_read_write_evt_FIXUP(void *p, struct NewGC *gc) {
 #define mark_read_write_evt_IS_CONST_SIZE 1
 
 
+static int mark_filesystem_change_evt_SIZE(void *p, struct NewGC *gc) {
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Filesystem_Change_Evt));
+}
+
+static int mark_filesystem_change_evt_MARK(void *p, struct NewGC *gc) {
+  Scheme_Filesystem_Change_Evt *fc = (Scheme_Filesystem_Change_Evt *)p;
+  gcMARK2(fc->sema, gc);
+  gcMARK2(fc->mref, gc);
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Filesystem_Change_Evt));
+}
+
+static int mark_filesystem_change_evt_FIXUP(void *p, struct NewGC *gc) {
+  Scheme_Filesystem_Change_Evt *fc = (Scheme_Filesystem_Change_Evt *)p;
+  gcFIXUP2(fc->sema, gc);
+  gcFIXUP2(fc->mref, gc);
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Filesystem_Change_Evt));
+}
+
+#define mark_filesystem_change_evt_IS_ATOMIC 0
+#define mark_filesystem_change_evt_IS_CONST_SIZE 1
+
+

racket/src/racket/src/mzmarksrc.c

@@ -1738,6 +1738,15 @@ mark_read_write_evt {
   gcBYTES_TO_WORDS(sizeof(Scheme_Read_Write_Evt));
 }
 
+mark_filesystem_change_evt {
+ mark:
+  Scheme_Filesystem_Change_Evt *fc = (Scheme_Filesystem_Change_Evt *)p;
+  gcMARK2(fc->sema, gc);
+  gcMARK2(fc->mref, gc);
+ size:
+  gcBYTES_TO_WORDS(sizeof(Scheme_Filesystem_Change_Evt));
+}
+
 END port;
 
 /**********************************************************************/

racket/src/racket/src/port.c

@@ -51,6 +51,9 @@
 # ifdef HAVE_POLL_SYSCALL
 #  include <poll.h>
 # endif
+# ifdef HAVE_INOTIFY_SYSCALL
+#  include <sys/inotify.h>
+# endif
 #endif
 #ifdef USE_ITIMER
 # include <sys/types.h>
@@ -443,6 +446,14 @@ static void rw_evt_wakeup(Scheme_Object *rww, void *fds);
 
 static int progress_evt_ready(Scheme_Object *rww, Scheme_Schedule_Info *sinfo);
 static int closed_evt_ready(Scheme_Object *rww, Scheme_Schedule_Info *sinfo);
+static int filesystem_change_evt_ready(Scheme_Object *evt, Scheme_Schedule_Info *sinfo);
+
+#ifdef DOS_FILE_SYSTEM
+static void filesystem_change_evt_need_wakeup (Scheme_Object *port, void *fds);
+#else
+# define filesystem_change_evt_need_wakeup NULL
+#endif
+
 
 static Scheme_Object *
 _scheme_make_named_file_input_port(FILE *fp, Scheme_Object *name, int regfile);
@@ -483,6 +494,13 @@ THREAD_LOCAL_DECL(static char *read_string_byte_buffer);
 
 #include "schwinfd.h"
 
+typedef struct Scheme_Filesystem_Change_Evt {
+  Scheme_Object so;
+  intptr_t fd;
+  Scheme_Object *sema;
+  Scheme_Custodian_Reference *mref;
+} Scheme_Filesystem_Change_Evt;
+
 /*========================================================================*/
 /*                             initialization                             */
 /*========================================================================*/
@@ -627,6 +645,8 @@ void scheme_init_port_wait()
   scheme_add_evt(scheme_progress_evt_type, (Scheme_Ready_Fun)progress_evt_ready, NULL, NULL, 1);
   scheme_add_evt(scheme_write_evt_type, (Scheme_Ready_Fun)rw_evt_ready, rw_evt_wakeup, NULL, 1);
   scheme_add_evt(scheme_port_closed_evt_type, (Scheme_Ready_Fun)closed_evt_ready, NULL, NULL, 1);
+  scheme_add_evt(scheme_filesystem_change_evt_type, (Scheme_Ready_Fun)filesystem_change_evt_ready, 
+                 filesystem_change_evt_need_wakeup, NULL, 1);
 }
 
 void scheme_init_port_places(void)
@@ -5952,6 +5972,243 @@ Scheme_Object *scheme_file_unlock(int argc, Scheme_Object **argv)
   return scheme_void;
 }
 
+/*========================================================================*/
+/*                        filesystem change events                        */
+/*========================================================================*/
+
+Scheme_Object *scheme_filesystem_change_evt(Scheme_Object *path, int flags, int signal_errs)
+{
+  char *filename;
+  int ok = 0, errid = 0;
+  intptr_t fd;
+
+  filename = scheme_expand_string_filename(path,
+					   "filesystem-change-evt",
+					   NULL,
+					   SCHEME_GUARD_FILE_EXISTS);
+#if defined(HAVE_KQUEUE_SYSCALL)
+  do {
+    fd = open(filename, flags | MZ_BINARY, 0666);
+  } while ((fd == -1) && (errno == EINTR));
+  if (fd == -1)
+    errid = errno;
+  else
+    ok = 1;
+#elif defined(HAVE_INOTIFY_SYSCALL)
+  /* This implementation uses a file descriptor for every event,
+     instead of using a watch descriptor for every event. This could
+     be improved, but note that the kqueue() implementation needs a
+     file descriptor per event, anyway. */
+  fd = inotify_init();
+  if (fd == -1)
+    errid = errno;
+  else {
+    int wd;
+    wd = inotify_add_watch(fd, filename, 
+                           (IN_CREATE | IN_DELETE | IN_DELETE_SELF
+                            | IN_MODIFY | IN_MOVE_SELF | IN_MOVED_TO
+                            | IN_ATTRIB | IN_ONESHOT));
+    if (wd == -1) {
+      errid = errno;
+      scheme_close_file_fd(fd);
+    } else {
+      ok = 1;
+      fcntl(fd, F_SETFL, MZ_NONBLOCKING);
+    }
+  }
+#elif defined(DOS_FILE_SYSTEM)
+  {
+    HANDLE h;
+    char *try_filename = filename;
+    
+    while (1) {
+      h = FindFirstChangeNotification(try_filename, FALSE, 
+                                      (FILE_NOTIFY_CHANGE_FILE_NAME
+                                       | FILE_NOTIFY_CHANGE_DIR_NAME
+                                       | FILE_NOTIFY_CHANGE_SIZE
+                                       | FILE_NOTIFY_CHANGE_LAST_WRITE
+                                       | FILE_NOTIFY_CHANGE_ATTRIBUTES));
+      if (h == INVALID_HANDLE_VALUE) {
+        /* If `filename' refers to a file, then monitor its enclosing directory. */
+        errid = GetLastError();
+        if ((try_filename == filename) && scheme_file_exists(filename)) {
+          Scheme_Object *base, *name;
+          int is_dir;
+          name = scheme_split_path(filename, strlen(filename), &base, &is_dir, SCHEME_PLATFORM_PATH_KIND);
+          try_filename = scheme_expand_string_filename(base,
+                                                       "filesystem-change-evt",
+                                                       NULL,
+                                                       SCHEME_GUARD_FILE_EXISTS);
+        } else
+          break;
+      } else {
+        fd = (intptr_t)h;
+        ok = 1;
+        break;
+      }
+    }
+  }
+#else
+# define NO_FILESYSTEM_CHANGE_EVTS
+  ok = 0;
+  errid = -1;
+#endif
+
+  if (!ok) { 
+    if (signal_errs) {
+#ifdef NO_FILESYSTEM_CHANGE_EVTS
+      scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
+                       "filesystem-change-evt: " NOT_SUPPORTED_STR "\n"
+                       "  path: %q\n",
+                       filename);
+#else
+      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                       "filesystem-change-evt: error generating event\n"
+                       "  path: %q\n"
+                       "  system error: %E",
+                       filename,
+                       errid);
+#endif
+    }
+    
+    return NULL;
+  }
+
+#if defined(NO_FILESYSTEM_CHANGE_EVTS)
+  return NULL;
+#elif defined(DOS_FILE_SYSTEM)
+  {
+    Scheme_Filesystem_Change_Evt *fc;
+    Scheme_Custodian_Reference *mref;
+
+    fc = MALLOC_ONE_TAGGED(Scheme_Filesystem_Change_Evt);
+    fc->so.type = scheme_filesystem_change_evt_type;
+    fc->fd = fd;
+
+    mref = scheme_add_managed(NULL, (Scheme_Object *)fc, scheme_filesystem_change_evt_cancel, NULL, 1);
+    fc->mref = mref;
+
+    return (Scheme_Object *)fc;
+  }
+#else
+  {
+    Scheme_Filesystem_Change_Evt *fc;
+    Scheme_Object *sema;
+    Scheme_Custodian_Reference *mref;
+
+    sema = scheme_fd_to_semaphore(fd, MZFD_CREATE_VNODE, 0);
+    if (!sema) {
+      const char *reason = "";
+
+#if defined(HAVE_KQUEUE_SYSCALL)
+      if (!scheme_fd_regular_file(fd, 1))
+        reason = ";\n not a regular file or directory";
+#endif
+
+      scheme_close_file_fd(fd);
+
+      if (signal_errs) {
+        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                         "filesystem-change-evt: cannot generate event%s\n"
+                         "  path: %q",
+                         reason,
+                         filename);
+      }
+      return NULL;
+    }
+
+    fc = MALLOC_ONE_TAGGED(Scheme_Filesystem_Change_Evt);
+    fc->so.type = scheme_filesystem_change_evt_type;
+    fc->fd = fd;
+    fc->sema = sema;
+
+    mref = scheme_add_managed(NULL, (Scheme_Object *)fc, scheme_filesystem_change_evt_cancel, NULL, 1);
+    fc->mref = mref;
+
+    return (Scheme_Object *)fc;
+  }
+#endif
+}
+
+void scheme_filesystem_change_evt_cancel(Scheme_Object *evt, void *ignored_data)
+{
+#ifndef NO_FILESYSTEM_CHANGE_EVTS
+  Scheme_Filesystem_Change_Evt *fc = (Scheme_Filesystem_Change_Evt *)evt;
+
+  if (fc->mref) {
+# if defined(DOS_FILE_SYSTEM)
+    if (fc->fd) {
+      FindCloseChangeNotification((HANDLE)fc->fd);
+      fc->fd = 0;
+    }
+# else
+    (void)scheme_fd_to_semaphore(fc->fd, MZFD_REMOVE, 0);
+    scheme_close_file_fd(fc->fd);
+    scheme_post_sema_all(fc->sema);
+# endif
+    scheme_remove_managed(fc->mref, (Scheme_Object *)fc);
+    fc->mref = NULL;
+  }
+#endif
+}
+
+static int filesystem_change_evt_ready(Scheme_Object *evt, Scheme_Schedule_Info *sinfo)
+{
+#ifndef NO_FILESYSTEM_CHANGE_EVTS
+  Scheme_Filesystem_Change_Evt *fc = (Scheme_Filesystem_Change_Evt *)evt;
+
+# if defined(DOS_FILE_SYSTEM)
+  if (fc->fd) {
+    if (WaitForSingleObject((HANDLE)fc->fd, 0) == WAIT_OBJECT_0) {
+      FindCloseChangeNotification((HANDLE)fc->fd);
+      fc->fd = 0;
+    }
+  }
+  
+  return !fc->fd;
+# else
+  if (scheme_try_plain_sema(fc->sema))
+    scheme_filesystem_change_evt_cancel((Scheme_Object *)fc, NULL);
+  else
+    scheme_check_fd_semaphores();
+  scheme_set_sync_target(sinfo, fc->sema, evt, NULL, 0, 1, NULL);
+# endif
+
+#endif
+
+  return 0;
+}
+
+#ifdef DOS_FILE_SYSTEM
+static void filesystem_change_evt_need_wakeup (Scheme_Object *evt, void *fds)
+{
+  Scheme_Filesystem_Change_Evt *fc = (Scheme_Filesystem_Change_Evt *)evt;
+
+  if (fc->fd)
+    scheme_add_fd_handle((void *)fc->fd, fds, 0);
+}
+#endif
+
+int scheme_fd_regular_file(intptr_t fd, int dir_ok)
+{
+#if defined(USE_FD_PORTS) && !defined(DOS_FILE_SYSTEM)
+  int ok;
+  struct stat buf;
+
+  do {
+    ok = fstat(fd, &buf);
+  } while ((ok == -1) && (errno == EINTR));
+
+  if (!S_ISREG(buf.st_mode)
+      && (!dir_ok || !S_ISDIR(buf.st_mode)))
+    return 0;
+  
+  return 1;
+#else
+  return 0;
+#endif
+}
+
 /*========================================================================*/
 /*                          FILE input ports                              */
 /*========================================================================*/
@@ -10861,6 +11118,8 @@ static void register_traversers(void)
 
   GC_REG_TRAV(scheme_subprocess_type, mark_subprocess);
   GC_REG_TRAV(scheme_write_evt_type, mark_read_write_evt);
+
+  GC_REG_TRAV(scheme_filesystem_change_evt_type, mark_filesystem_change_evt);
 }
 
 END_XFORM_SKIP;

racket/src/racket/src/portfun.c

@@ -126,6 +126,10 @@ static Scheme_Object *port_counts_lines_p(int, Scheme_Object **args);
 static Scheme_Object *port_next_location(int, Scheme_Object **args);
 static Scheme_Object *set_port_next_location(int, Scheme_Object **args);
 
+static Scheme_Object *filesystem_change_evt(int, Scheme_Object **args);
+static Scheme_Object *filesystem_change_evt_p(int, Scheme_Object **args);
+static Scheme_Object *filesystem_change_evt_cancel(int, Scheme_Object **args);
+
 static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Object *argv[]);
 static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[]);
 static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[]);
@@ -260,6 +264,10 @@ scheme_init_port_fun(Scheme_Env *env)
   GLOBAL_PRIM_W_ARITY2("port-next-location",    port_next_location,     1, 1, 3,  3, env);
   GLOBAL_PRIM_W_ARITY("set-port-next-location!",  set_port_next_location, 4, 4, env);
 
+  GLOBAL_PRIM_W_ARITY("filesystem-change-evt",  filesystem_change_evt,   1, 2, env);
+  GLOBAL_NONCM_PRIM("filesystem-change-evt?",   filesystem_change_evt_p, 1, 1, env);
+  GLOBAL_NONCM_PRIM("filesystem-change-evt-cancel",  filesystem_change_evt_cancel, 1, 1, env);
+
   GLOBAL_NONCM_PRIM("read",                           read_f,                         0, 1, env);
   GLOBAL_NONCM_PRIM("read/recursive",                 read_recur_f,                   0, 4, env);
   GLOBAL_NONCM_PRIM("read-syntax",                    read_syntax_f,                  0, 2, env);
@@ -4319,6 +4327,40 @@ static Scheme_Object *set_port_next_location(int argc, Scheme_Object *argv[])
   return scheme_void;
 }
 
+static Scheme_Object *filesystem_change_evt(int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *e;
+
+  if (!SCHEME_PATH_STRINGP(argv[0]))
+    scheme_wrong_contract("filesystem-change-evt", "path-string?", 0, argc, argv);
+  if (argc > 1)
+    scheme_check_proc_arity("filesystem-change-evt", 0, 1, argc, argv);
+
+  e = scheme_filesystem_change_evt(argv[0], 0, (argc < 2));
+
+  if (!e)
+    return _scheme_tail_apply(argv[1], 0, NULL);
+  else
+    return e;
+}
+
+static Scheme_Object *filesystem_change_evt_p(int argc, Scheme_Object **argv)
+{
+  return (SAME_TYPE(scheme_filesystem_change_evt_type, SCHEME_TYPE(argv[0]))
+          ? scheme_true
+          : scheme_false);
+}
+
+static Scheme_Object *filesystem_change_evt_cancel(int argc, Scheme_Object **argv)
+{
+  if (!SAME_TYPE(scheme_filesystem_change_evt_type, SCHEME_TYPE(argv[0])))
+    scheme_wrong_contract("filesystem-change-evt-cancel", "filesystem-change-evt?", 0, argc, argv);
+
+  scheme_filesystem_change_evt_cancel(argv[0], NULL);
+
+  return scheme_void;
+}
+
 static intptr_t get_number(Scheme_Object *port, intptr_t pos)
 {
   unsigned char buffer[4];

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1105
+#define EXPECTED_PRIM_COUNT 1108
 #define EXPECTED_UNSAFE_COUNT 100
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schpriv.h

@@ -3876,6 +3876,12 @@ intptr_t scheme_redirect_get_or_peek_bytes(Scheme_Input_Port *orig_port,
                                            Scheme_Object *unless,
                                            Scheme_Schedule_Info *sinfo);
 
+Scheme_Object *scheme_filesystem_change_evt(Scheme_Object *path, int flags, int report_errs);
+void scheme_filesystem_change_evt_cancel(Scheme_Object *evt, void *ignored_data);
+
+int scheme_fd_regular_file(intptr_t fd, int dir_ok);
+void scheme_check_fd_semaphores(void);
+
 /*========================================================================*/
 /*                         memory debugging                               */
 /*========================================================================*/

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.900.3"
+#define MZSCHEME_VERSION "5.3.900.4"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 900
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/stypes.h

@@ -209,83 +209,84 @@ enum {
   scheme_struct_proc_shape_type,        /* 185 */
   scheme_phantom_bytes_type,            /* 186 */
   scheme_environment_variables_type,    /* 187 */
+  scheme_filesystem_change_evt_type,    /* 188 */
                                         
 #ifdef MZTAG_REQUIRED                            
-  _scheme_last_normal_type_,            /* 188 */
+  _scheme_last_normal_type_,            /* 189 */
                                                  
-  scheme_rt_weak_array,                 /* 189 */
+  scheme_rt_weak_array,                 /* 190 */
                                         
-  scheme_rt_comp_env,                   /* 190 */
+  scheme_rt_comp_env,                   /* 191 */
-  scheme_rt_constant_binding,           /* 191 */
+  scheme_rt_constant_binding,           /* 192 */
-  scheme_rt_resolve_info,               /* 192 */
+  scheme_rt_resolve_info,               /* 193 */
-  scheme_rt_unresolve_info,             /* 193 */
+  scheme_rt_unresolve_info,             /* 194 */
-  scheme_rt_optimize_info,              /* 194 */
+  scheme_rt_optimize_info,              /* 195 */
-  scheme_rt_compile_info,               /* 195 */
+  scheme_rt_compile_info,               /* 196 */
-  scheme_rt_cont_mark,                  /* 196 */
+  scheme_rt_cont_mark,                  /* 197 */
-  scheme_rt_saved_stack,                /* 197 */
+  scheme_rt_saved_stack,                /* 198 */
-  scheme_rt_reply_item,                 /* 198 */
+  scheme_rt_reply_item,                 /* 199 */
-  scheme_rt_closure_info,               /* 199 */
+  scheme_rt_closure_info,               /* 200 */
-  scheme_rt_overflow,                   /* 200 */
+  scheme_rt_overflow,                   /* 201 */
-  scheme_rt_overflow_jmp,               /* 201 */
+  scheme_rt_overflow_jmp,               /* 202 */
-  scheme_rt_meta_cont,                  /* 202 */
+  scheme_rt_meta_cont,                  /* 203 */
-  scheme_rt_dyn_wind_cell,              /* 203 */
+  scheme_rt_dyn_wind_cell,              /* 204 */
-  scheme_rt_dyn_wind_info,              /* 204 */
+  scheme_rt_dyn_wind_info,              /* 205 */
-  scheme_rt_dyn_wind,                   /* 205 */
+  scheme_rt_dyn_wind,                   /* 206 */
-  scheme_rt_dup_check,                  /* 206 */
+  scheme_rt_dup_check,                  /* 207 */
-  scheme_rt_thread_memory,              /* 207 */
+  scheme_rt_thread_memory,              /* 208 */
-  scheme_rt_input_file,                 /* 208 */
+  scheme_rt_input_file,                 /* 209 */
-  scheme_rt_input_fd,                   /* 209 */
+  scheme_rt_input_fd,                   /* 210 */
-  scheme_rt_oskit_console_input,        /* 210 */
+  scheme_rt_oskit_console_input,        /* 211 */
-  scheme_rt_tested_input_file,          /* 211 */
+  scheme_rt_tested_input_file,          /* 212 */
-  scheme_rt_tested_output_file,         /* 212 */
+  scheme_rt_tested_output_file,         /* 213 */
-  scheme_rt_indexed_string,             /* 213 */
+  scheme_rt_indexed_string,             /* 214 */
-  scheme_rt_output_file,                /* 214 */
+  scheme_rt_output_file,                /* 215 */
-  scheme_rt_load_handler_data,          /* 215 */
+  scheme_rt_load_handler_data,          /* 216 */
-  scheme_rt_pipe,                       /* 216 */
+  scheme_rt_pipe,                       /* 217 */
-  scheme_rt_beos_process,               /* 217 */
+  scheme_rt_beos_process,               /* 218 */
-  scheme_rt_system_child,               /* 218 */
+  scheme_rt_system_child,               /* 219 */
-  scheme_rt_tcp,                        /* 219 */
+  scheme_rt_tcp,                        /* 220 */
-  scheme_rt_write_data,                 /* 220 */
+  scheme_rt_write_data,                 /* 221 */
-  scheme_rt_tcp_select_info,            /* 221 */
+  scheme_rt_tcp_select_info,            /* 222 */
-  scheme_rt_param_data,                 /* 222 */
+  scheme_rt_param_data,                 /* 223 */
-  scheme_rt_will,                       /* 223 */
+  scheme_rt_will,                       /* 224 */
-  scheme_rt_linker_name,                /* 224 */
+  scheme_rt_linker_name,                /* 225 */
-  scheme_rt_param_map,                  /* 225 */
+  scheme_rt_param_map,                  /* 226 */
-  scheme_rt_finalization,               /* 226 */
+  scheme_rt_finalization,               /* 227 */
-  scheme_rt_finalizations,              /* 227 */
+  scheme_rt_finalizations,              /* 228 */
-  scheme_rt_cpp_object,                 /* 228 */
+  scheme_rt_cpp_object,                 /* 229 */
-  scheme_rt_cpp_array_object,           /* 229 */
+  scheme_rt_cpp_array_object,           /* 230 */
-  scheme_rt_stack_object,               /* 230 */
+  scheme_rt_stack_object,               /* 231 */
-  scheme_rt_preallocated_object,        /* 231 */
+  scheme_rt_preallocated_object,        /* 232 */
-  scheme_thread_hop_type,               /* 232 */
+  scheme_thread_hop_type,               /* 233 */
-  scheme_rt_srcloc,                     /* 233 */
+  scheme_rt_srcloc,                     /* 234 */
-  scheme_rt_evt,                        /* 234 */
+  scheme_rt_evt,                        /* 235 */
-  scheme_rt_syncing,                    /* 235 */
+  scheme_rt_syncing,                    /* 236 */
-  scheme_rt_comp_prefix,                /* 236 */
+  scheme_rt_comp_prefix,                /* 237 */
-  scheme_rt_user_input,                 /* 237 */
+  scheme_rt_user_input,                 /* 238 */
-  scheme_rt_user_output,                /* 238 */
+  scheme_rt_user_output,                /* 239 */
-  scheme_rt_compact_port,               /* 239 */
+  scheme_rt_compact_port,               /* 240 */
-  scheme_rt_read_special_dw,            /* 240 */
+  scheme_rt_read_special_dw,            /* 241 */
-  scheme_rt_regwork,                    /* 241 */
+  scheme_rt_regwork,                    /* 242 */
-  scheme_rt_rx_lazy_string,             /* 242 */
+  scheme_rt_rx_lazy_string,             /* 243 */
-  scheme_rt_buf_holder,                 /* 243 */
+  scheme_rt_buf_holder,                 /* 244 */
-  scheme_rt_parameterization,           /* 244 */
+  scheme_rt_parameterization,           /* 245 */
-  scheme_rt_print_params,               /* 245 */
+  scheme_rt_print_params,               /* 246 */
-  scheme_rt_read_params,                /* 246 */
+  scheme_rt_read_params,                /* 247 */
-  scheme_rt_native_code,                /* 247 */
+  scheme_rt_native_code,                /* 248 */
-  scheme_rt_native_code_plus_case,      /* 248 */
+  scheme_rt_native_code_plus_case,      /* 249 */
-  scheme_rt_jitter_data,                /* 249 */
+  scheme_rt_jitter_data,                /* 250 */
-  scheme_rt_module_exports,             /* 250 */
+  scheme_rt_module_exports,             /* 251 */
-  scheme_rt_delay_load_info,            /* 251 */
+  scheme_rt_delay_load_info,            /* 252 */
-  scheme_rt_marshal_info,               /* 252 */
+  scheme_rt_marshal_info,               /* 253 */
-  scheme_rt_unmarshal_info,             /* 253 */
+  scheme_rt_unmarshal_info,             /* 254 */
-  scheme_rt_runstack,                   /* 254 */
+  scheme_rt_runstack,                   /* 255 */
-  scheme_rt_sfs_info,                   /* 255 */
+  scheme_rt_sfs_info,                   /* 256 */
-  scheme_rt_validate_clearing,          /* 256 */
+  scheme_rt_validate_clearing,          /* 257 */
-  scheme_rt_avl_node,                   /* 257 */
+  scheme_rt_avl_node,                   /* 258 */
-  scheme_rt_lightweight_cont,           /* 258 */
+  scheme_rt_lightweight_cont,           /* 259 */
-  scheme_rt_export_info,                /* 259 */
+  scheme_rt_export_info,                /* 260 */
-  scheme_rt_cont_jmp,                   /* 260 */
+  scheme_rt_cont_jmp,                   /* 261 */
 #endif
 
   _scheme_last_type_

racket/src/racket/src/thread.c

@@ -3480,8 +3480,10 @@ Scheme_Object *scheme_fd_to_semaphore(intptr_t fd, int mode, int is_socket)
     return NULL;
 
 # ifdef HAVE_KQUEUE_SYSCALL
-  if (!is_socket)
+  if (!is_socket) {
-    return NULL; /* kqueue() might not work on devices, such as ttys */
+    if (!scheme_fd_regular_file(fd, 10))
+      return NULL; /* kqueue() might not work on devices, such as ttys */
+  }
   if (scheme_semaphore_fd_kqueue < 0) {
     scheme_semaphore_fd_kqueue = kqueue();
     if (scheme_semaphore_fd_kqueue < 0) {
@@ -3504,6 +3506,7 @@ Scheme_Object *scheme_fd_to_semaphore(intptr_t fd, int mode, int is_socket)
   v = scheme_hash_get(scheme_semaphore_fd_mapping, key);
   if (!v && ((mode == MZFD_CHECK_READ)
              || (mode == MZFD_CHECK_WRITE)
+             || (mode == MZFD_CHECK_VNODE)
              || (mode == MZFD_REMOVE)))
     return NULL;
 
@@ -3529,13 +3532,14 @@ Scheme_Object *scheme_fd_to_semaphore(intptr_t fd, int mode, int is_socket)
     scheme_hash_set(scheme_semaphore_fd_mapping, key, NULL);
 # ifdef HAVE_KQUEUE_SYSCALL
     {
-      GC_CAN_IGNORE struct kevent kev[2];
+      GC_CAN_IGNORE struct kevent kev[3];
       struct timespec timeout = {0, 0};
       int kr;
       EV_SET(kev, fd, EVFILT_READ, EV_DELETE, 0, 0, NULL);
-      EV_SET(&kev[1], fd, EVFILT_READ, EV_DELETE, 0, 0, NULL);
+      EV_SET(&kev[1], fd, EVFILT_WRITE, EV_DELETE, 0, 0, NULL);
+      EV_SET(&kev[2], fd, EVFILT_VNODE, EV_DELETE, 0, 0, NULL);
       do {
-        kr = kevent(scheme_semaphore_fd_kqueue, kev, 2, NULL, 0, &timeout);
+        kr = kevent(scheme_semaphore_fd_kqueue, kev, 3, NULL, 0, &timeout);
       } while ((kr == -1) && (errno == EINTR));
       log_kqueue_error("remove", kr);
     }
@@ -3552,10 +3556,13 @@ Scheme_Object *scheme_fd_to_semaphore(intptr_t fd, int mode, int is_socket)
 # endif
     s = NULL;
   } else if ((mode == MZFD_CHECK_READ)
-             || (mode == MZFD_CREATE_READ)) {
+             || (mode == MZFD_CREATE_READ)
+             || (mode == MZFD_CHECK_VNODE)
+             || (mode == MZFD_CREATE_VNODE)) {
     s = SCHEME_VEC_ELS(v)[0];
     if (SCHEME_FALSEP(s)) {
-      if (mode == MZFD_CREATE_READ) {
+      if ((mode == MZFD_CREATE_READ)
+          || (mode == MZFD_CREATE_VNODE)) {
         s = scheme_make_sema(0);
         SCHEME_VEC_ELS(v)[0] = s;
 # ifdef HAVE_KQUEUE_SYSCALL
@@ -3563,7 +3570,13 @@ Scheme_Object *scheme_fd_to_semaphore(intptr_t fd, int mode, int is_socket)
           GC_CAN_IGNORE struct kevent kev;
           struct timespec timeout = {0, 0};
           int kr;
-          EV_SET(&kev, fd, EVFILT_READ, EV_ADD | EV_ONESHOT, 0, 0, NULL);
+          if (mode == MZFD_CREATE_READ)
+            EV_SET(&kev, fd, EVFILT_READ, EV_ADD | EV_ONESHOT, 0, 0, NULL);
+          else
+            EV_SET(&kev, fd, EVFILT_VNODE, EV_ADD | EV_ONESHOT, 
+                   (NOTE_DELETE | NOTE_WRITE | NOTE_EXTEND 
+                    | NOTE_RENAME | NOTE_ATTRIB),
+                   0, NULL);
           do {
             kr = kevent(scheme_semaphore_fd_kqueue, &kev, 1, NULL, 0, &timeout);
           } while ((kr == -1) && (errno == EINTR));
@@ -3586,7 +3599,8 @@ Scheme_Object *scheme_fd_to_semaphore(intptr_t fd, int mode, int is_socket)
       } else
         s = NULL;
     }
-  } else {
+  } else if ((mode == MZFD_CHECK_WRITE)
+             || (mode == MZFD_CREATE_WRITE)) {
     s = SCHEME_VEC_ELS(v)[1];
     if (SCHEME_FALSEP(s)) {
       if (mode == MZFD_CREATE_WRITE) {
@@ -3650,7 +3664,7 @@ static int check_fd_semaphores()
       key = scheme_make_integer_value(kev.ident);
       v = scheme_hash_get(scheme_semaphore_fd_mapping, key);
       if (v) {
-        if (kev.filter == EVFILT_READ) {
+        if ((kev.filter == EVFILT_READ) || (kev.filter == EVFILT_VNODE)) {
           s = SCHEME_VEC_ELS(v)[0];
           if (!SCHEME_FALSEP(s)) {
             scheme_post_sema_all(s);
@@ -3849,6 +3863,11 @@ static int check_fd_semaphores()
 #endif
 }
 
+void scheme_check_fd_semaphores(void)
+{
+  (void)check_fd_semaphores();
+}
+
 typedef struct {
   int running;
   double sleep_end;

racket/src/racket/src/type.c

@@ -209,6 +209,7 @@ scheme_init_type ()
   set_name(scheme_struct_type_type, "<struct-type>");
   set_name(scheme_listener_type, "<tcp-listener>");
   set_name(scheme_tcp_accept_evt_type, "<tcp-accept-evt>");
+  set_name(scheme_filesystem_change_evt_type, "<filesystem-change-evt>");
   set_name(scheme_namespace_type, "<namespace>");
   set_name(scheme_config_type, "<parameterization>");
   set_name(scheme_will_executor_type, "<will-executor>");
@@ -613,7 +614,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_unix_path_type, bstring_obj);
   GC_REG_TRAV(scheme_windows_path_type, bstring_obj);
   GC_REG_TRAV(scheme_symbol_type, symbol_obj);
-#ifdef MZ_USE_PLACES  
+#ifdef MZ_USE_PLACES
   GC_REG_TRAV(scheme_serialized_symbol_type, bstring_obj);
   GC_REG_TRAV(scheme_serialized_keyword_type, bstring_obj);
   GC_REG_TRAV(scheme_place_dead_type, small_object);