add ffi/unsafe/port

Provide unsafe functions for working with file descriptors and
sockets. Although more functions are potentially useful, these
reflect the one scurrently exported by the C API.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.11.0.3")
+(define version "6.11.0.4")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/foreign/derived.scrbl

@@ -15,6 +15,7 @@
 @include-section["atomic.scrbl"]
 @include-section["try-atomic.scrbl"]
 @include-section["schedule.scrbl"]
+@include-section["port.scrbl"]
 @include-section["global.scrbl"]
 @include-section["objc.scrbl"]
 @include-section["ns.scrbl"]

pkgs/racket-doc/scribblings/foreign/port.scrbl

@@ -0,0 +1,92 @@
+#lang scribble/doc
+@(require "utils.rkt"
+          (for-label ffi/unsafe/port))
+
+@title{Ports}
+
+@defmodule[ffi/unsafe/port]{The
+@racketmodname[ffi/unsafe/port] library provides functions for working
+with ports, file descriptors, and sockets. The library's operations
+are unsafe, because no checking is performed on file descriptors and
+sockets, and misuse of file descriptors and sockets can break other
+objects.}
+
+@history[#:added "6.11.0.4"]
+
+@deftogether[(
+@defproc[(unsafe-file-descriptor->port [fd exact-integer?]
+                                       [name any/c]
+                                       [mode (listof (or/c 'read 'write 'text 'regular-file))])
+         (or/c port? (values input-port? output-port?))]
+@defproc[(unsafe-socket->port [socket exact-integer?]
+                              [name bytes?]
+                              [mode (listof (or/c 'no-close))])
+         (values input-port? output-port?)]
+)]{         
+
+Returns an input port and/or output port for the given file descriptor
+or socket. On Windows, a ``file descriptor'' corresponds to a file
+@tt{HANDLE}, while a socket corresponds to a @tt{SOCKET}. One Unix, a
+socket is a file descriptor, but using socket-specific functions may
+enable socket-specific functionality.
+
+The @racket[name] argument determines the port's name as reported by
+@racket[object-name]. The @racket[name] must be a UTF-8 encoding that
+is converted to a symbol for the socket name.
+
+For a file descriptor, the @racket[mode] list must include at least
+one of @racket['read] or @racket['write], and two ports are returned
+if @racket[mode] includes both @racket['read] and @racket['write]. The
+@racket['text] mode affects only Windows ports. The
+@racket['regular-file] mode indicates that the file descriptor
+corresponds to a regular file (which has the property, for example,
+that reading never blocks). Closing all returned file-descriptor ports
+closes the file descriptor.
+
+For a socket, the @racket[mode] list can include @racket['no-close],
+in which case closing both of the returned ports does not close the
+socket.
+
+For any kind of result port, closing the resulting ports readies and
+unregisters any semaphores for the file descriptor or socket that were
+previously created with @racket[unsafe-file-descriptor->semaphore]
+@racket[unsafe-socket->semaphore].}
+
+
+@deftogether[(
+@defproc[(unsafe-port->file-descriptor [p port?])
+         (or/c exact-integer? #f)]
+@defproc[(unsafe-port->socket [p port?])
+         (or/c exact-integer? #f)]
+)]{
+
+Returns a file descriptor (which is a @tt{HANDLE} value on Windows) of
+a socket for @racket[port] if it has one, @racket[#f] otherwise.}
+
+
+@deftogether[(
+@defproc[(unsafe-file-descriptor->semaphore [fd exact-integer?]
+                                            [mode (or/c 'read 'write 'check-read 'check-write 'remove)])
+         (or/c semaphore? #f)]
+@defproc[(unsafe-socket->semaphore [socket exact-integer?]
+                                   [mode (or/c 'read 'write 'check-read 'check-write 'remove)])
+         (or/c semaphore? #f)]
+)]{         
+
+For @racket[mode] as @racket['read] or @racket['write], returns a
+semaphore that becomes ready when @racket[fd] or @racket[socket]
+becomes ready for reading or writing, respectively. The result is
+@racket[#f] if a conversion to a semaphore is not supported for the
+current platform or for the given file descriptor or socket.
+
+The @racket['read-check] and @racket['write-check] modes are like
+@racket['read] and @racket['write], but the result if @racket[#f] if a
+semaphore is not already generated for the specified file descriptor
+or socket in the specified mode.
+
+The @racket['remove] mode readies and unregisters any semaphores
+previously created for the given file descriptor or socket. Semaphores
+must be unregistered before the file descriptor or socket is closed.
+Beware that closing a port from @racket[unsafe-file-descriptor->port]
+or @racket[unsafe-socket->port] will also ready and unregister
+semaphores.}

pkgs/racket-doc/scribblings/foreign/schedule.scrbl

@@ -6,9 +6,9 @@
 
 @defmodule[ffi/unsafe/schedule]{The
 @racketmodname[ffi/unsafe/schedule] library provides functions for
-cooperating with the thread scheduler and manipulating it. These
-operations are unsafe because callbacks run in @tech{atomic mode}
-and in an unspecified thread.}
+cooperating with the thread scheduler and manipulating it. The
+library's operations are unsafe because callbacks run in @tech{atomic
+mode} and in an unspecified thread.}
 
 @history[#:added "6.11.0.1"]
 

pkgs/racket-test-core/tests/racket/portlib.rktl

@@ -5,7 +5,9 @@
 
 (define SLEEP-TIME 0.1)
 
-(require racket/port)
+(require racket/port
+         ffi/unsafe
+         ffi/unsafe/port)
 
 ;; ----------------------------------------
 
@@ -1240,4 +1242,40 @@
 
 ;; --------------------------------------------------
 
+(when (memq (system-type) '(unix macosx))
+  (define open (get-ffi-obj 'open #f (_fun _path _int -> _int)))
+  (define O_RDWR #x0002) ; probably
+  (for ([mode (in-list '((read) (write) (read write)))])
+    (define /dev/null-fd (open "/dev/null" O_RDWR))
+    (unless (= -1 /dev/null-fd)
+      (call-with-values (lambda () (unsafe-file-descriptor->port /dev/null-fd 'dev-null mode))
+        (case-lambda
+          [(p)
+           (test (equal? mode '(read)) input-port? p)
+           (test (equal? mode '(write)) output-port? p)
+           (test /dev/null-fd unsafe-port->file-descriptor p)
+           (define s (unsafe-file-descriptor->semaphore /dev/null-fd (car mode)))
+           (test #t 'sema (or (semaphore? s) (not s)))
+           (test s unsafe-file-descriptor->semaphore /dev/null-fd (case (car mode)
+                                                                    [(read) 'check-read]
+                                                                    [(write) 'check-write]))
+           (when s
+             (semaphore-wait s)
+             (unsafe-file-descriptor->semaphore /dev/null-fd 'remove))
+           (test #f unsafe-port->socket p)
+           (if (input-port? p)
+               (close-input-port p)
+               (close-output-port p))]
+          [(i o)
+           (test #t input-port? i)
+           (test #t output-port? o)
+           (test /dev/null-fd unsafe-port->file-descriptor i)
+           (test /dev/null-fd unsafe-port->file-descriptor o)
+           (test #f unsafe-port->socket i)
+           (test #f unsafe-port->socket o)
+           (close-input-port i)
+           (close-output-port o)])))))
+
+;; --------------------------------------------------
+
 (report-errs)

racket/collects/ffi/unsafe/port.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+(require (only-in '#%unsafe
+                  unsafe-file-descriptor->port
+                  unsafe-port->file-descriptor
+                  unsafe-file-descriptor->semaphore
+                  unsafe-socket->port
+                  unsafe-port->socket
+                  unsafe-socket->semaphore))
+(provide (all-from-out '#%unsafe))

racket/collects/racket/unsafe/ops.rkt

@@ -20,6 +20,12 @@
                      unsafe-poll-ctx-eventmask-wakeup
                      unsafe-poll-ctx-milliseconds-wakeup
                      unsafe-signal-received unsafe-set-sleep-in-thread!
+                     unsafe-file-descriptor->port
+                     unsafe-port->file-descriptor
+                     unsafe-file-descriptor->semaphore
+                     unsafe-socket->port
+                     unsafe-port->socket
+                     unsafe-socket->semaphore
                      unsafe-thread-at-root
                      unsafe-make-custodian-at-root
                      unsafe-custodian-register

racket/src/racket/src/cstartup.inc

@@ -1,5 +1,5 @@
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,50,84,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,52,84,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0,18,
 0,22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0,82,0,
 89,0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0,173,
@@ -102,7 +102,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 2091);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,50,84,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,52,84,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,0,183,0,0,0,1,0,0,8,0,16,
 0,29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0,193,0,
 211,0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130,1,145,
@@ -1011,7 +1011,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 19016);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,50,84,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,52,84,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0,23,
 0,48,0,65,0,83,0,105,0,128,0,149,0,171,0,181,0,191,0,199,0,
 209,0,217,0,0,0,253,1,0,0,3,1,5,105,110,115,112,48,76,35,37,
@@ -1042,7 +1042,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 582);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,50,84,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,52,84,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,0,102,0,0,0,1,0,0,8,0,15,
 0,26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0,171,0,
 186,0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103,1,108,
@@ -1538,7 +1538,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 10344);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,50,84,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,52,84,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,0,18,0,0,0,1,0,0,8,0,18,
 0,22,0,28,0,42,0,56,0,68,0,88,0,102,0,117,0,130,0,135,0,
 139,0,151,0,235,0,242,0,20,1,0,0,224,1,0,0,3,1,5,105,110,

racket/src/racket/src/env.c

@@ -333,6 +333,7 @@ static void init_unsafe(Scheme_Env *env)
   scheme_init_unsafe_vector(unsafe_env);
   scheme_init_unsafe_fun(unsafe_env);
   scheme_init_unsafe_thread(unsafe_env);
+  scheme_init_unsafe_port(unsafe_env);
 
   scheme_init_extfl_unsafe_number(unsafe_env);
   scheme_init_extfl_unsafe_numarith(unsafe_env);

racket/src/racket/src/port.c

@@ -234,6 +234,13 @@ static void register_subprocess_wait();
 
 static void block_timer_signals(int block);
 
+static Scheme_Object *unsafe_fd_to_port(int, Scheme_Object *[]);
+static Scheme_Object *unsafe_port_to_fd(int, Scheme_Object *[]);
+static Scheme_Object *unsafe_fd_to_semaphore(int, Scheme_Object *[]);
+static Scheme_Object *unsafe_socket_to_port(int, Scheme_Object *[]);
+static Scheme_Object *unsafe_port_to_socket(int, Scheme_Object *[]);
+static Scheme_Object *unsafe_socket_to_semaphore(int, Scheme_Object *[]);
+
 typedef struct Scheme_Read_Write_Evt {
   Scheme_Object so;
   Scheme_Object *port;
@@ -403,6 +410,17 @@ void scheme_init_port_wait()
                  filesystem_change_evt_need_wakeup, NULL, 1);
 }
 
+void scheme_init_unsafe_port (Scheme_Env *env)
+{
+  GLOBAL_PRIM_W_ARITY("unsafe-file-descriptor->port", unsafe_fd_to_port, 3, 3, env);
+  GLOBAL_PRIM_W_ARITY("unsafe-port->file-descriptor", unsafe_port_to_fd, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("unsafe-file-descriptor->semaphore", unsafe_fd_to_semaphore, 2, 2, env);
+
+  GLOBAL_PRIM_W_ARITY("unsafe-socket->port", unsafe_socket_to_port, 3, 3, env);
+  GLOBAL_PRIM_W_ARITY("unsafe-port->socket", unsafe_port_to_socket, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("unsafe-socket->semaphore", unsafe_socket_to_semaphore, 2, 2, env);
+}
+
 void scheme_init_port_places(void)
 {
 
@@ -3408,6 +3426,142 @@ intptr_t scheme_get_port_fd(Scheme_Object *p)
     return -1;
 }
 
+static Scheme_Object *unsafe_handle_to_port(const char *who, int argc, Scheme_Object *argv[], int socket)
+{
+  Scheme_Object *name = argv[1], *l, *a;
+  intptr_t s;
+  int closemode = 1;
+  int regfile = 0;
+  int textmode = 0;
+  int readmode = 0, writemode = 0;
+
+  if (!scheme_get_int_val(argv[0], &s))
+    scheme_wrong_contract(who, "handle-integer?", 0, argc, argv);
+
+  if (socket) {
+    if (!SCHEME_BYTE_STRINGP(name))
+      scheme_wrong_contract(who, "bytes?", 1, argc, argv);
+  }
+  
+  l = argv[2];
+  while (SCHEME_PAIRP(l)) {
+    a = SCHEME_CAR(l);
+    if (!SCHEME_SYMBOLP(a) || SCHEME_SYM_WEIRDP(a))
+      break;
+    if (socket) {
+      if (!strcmp(SCHEME_SYM_VAL(a), "no-close"))
+        closemode = 0;
+    } else {
+      if (!strcmp(SCHEME_SYM_VAL(a), "read"))
+        readmode = 1;
+      else if (!strcmp(SCHEME_SYM_VAL(a), "write"))
+        writemode = 1;
+      else if (!strcmp(SCHEME_SYM_VAL(a), "text"))
+        textmode = 1;
+      else if (!strcmp(SCHEME_SYM_VAL(a), "regular-file"))
+        regfile = 1;
+      else
+        break;
+    }
+    l = SCHEME_CDR(l);
+  }
+  if (!SCHEME_NULLP(l))
+    scheme_wrong_contract(who, "mode-symbol-list?", 2, argc, argv);
+
+  if (socket) {
+    Scheme_Object *p[2];
+    scheme_socket_to_ports(s, SCHEME_BYTE_STR_VAL(name), closemode, &p[0], &p[1]);
+    return scheme_values(2, p);
+  } else if (writemode)
+    return scheme_make_fd_output_port(s, name, regfile, textmode, readmode);
+  else if (readmode)
+    return scheme_make_fd_input_port(s, name, regfile, textmode);
+  else {
+    scheme_contract_error(who,
+                          "mode list must include at least one of 'read or 'write"
+                          "mode list", 1, argv[2],
+                          NULL);
+    return NULL;
+  }
+}
+
+static Scheme_Object *unsafe_fd_to_port(int argc, Scheme_Object *argv[])
+{
+  return unsafe_handle_to_port("unsafe-file-descriptor->port", argc, argv, 0);
+}
+  
+static Scheme_Object *unsafe_socket_to_port(int argc, Scheme_Object *argv[])
+{
+  return unsafe_handle_to_port("unsafe-socket->port", argc, argv, 1);
+}
+  
+static Scheme_Object *unsafe_port_to_fd(int argc, Scheme_Object *argv[])
+{
+  intptr_t s;
+  
+  if (scheme_get_port_file_descriptor(argv[0], &s))
+    return scheme_make_integer_value(s);
+  else {
+    if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
+      scheme_wrong_contract("unsafe-port->file-descriptor", "port?", 0, argc, argv);
+    return scheme_false;
+  }
+}
+
+static Scheme_Object *unsafe_port_to_socket(int argc, Scheme_Object *argv[])
+{
+  intptr_t s;
+  
+  if (scheme_get_port_socket(argv[0], &s))
+    return scheme_make_integer_value(s);
+  else {
+    if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
+      scheme_wrong_contract("unsafe-port->socket", "port?", 0, argc, argv);
+    return scheme_false;
+  }
+}
+
+static Scheme_Object *unsafe_handle_to_semaphore(const char *who, int argc, Scheme_Object *argv[], int is_socket)
+{
+  Scheme_Object *a = argv[1];
+  intptr_t s;
+  int mode;
+
+  if (!scheme_get_int_val(argv[0], &s))
+    scheme_wrong_contract(who, "handle-integer?", 0, argc, argv);
+
+  if (!SCHEME_SYMBOLP(a) || SCHEME_SYM_WEIRDP(a))
+    mode = -1;
+  else if (!strcmp(SCHEME_SYM_VAL(a), "read"))
+    mode = MZFD_CREATE_READ;
+  else if (!strcmp(SCHEME_SYM_VAL(a), "write"))
+    mode = MZFD_CREATE_WRITE;
+  else if (!strcmp(SCHEME_SYM_VAL(a), "check-read"))
+    mode = MZFD_CHECK_READ;
+  else if (!strcmp(SCHEME_SYM_VAL(a), "check-write"))
+    mode = MZFD_CHECK_WRITE;
+  else if (!strcmp(SCHEME_SYM_VAL(a), "remove"))
+    mode = MZFD_REMOVE;
+  else 
+    mode = -1;
+
+  if (mode == -1)
+    scheme_wrong_contract(who, "semaphore-mode-symbol?", 1, argc, argv);
+
+  a = scheme_fd_to_semaphore(s, mode, is_socket);
+  return (a ? a : scheme_false);
+}
+
+static Scheme_Object *unsafe_fd_to_semaphore(int argc, Scheme_Object *argv[])
+{
+  return unsafe_handle_to_semaphore("unsafe-file-descriptor->semaphore", argc, argv, 0);
+}
+
+static Scheme_Object *unsafe_socket_to_semaphore(int argc, Scheme_Object *argv[])
+{
+  return unsafe_handle_to_semaphore("unsafe-socket->semaphore", argc, argv, 1);
+}
+
 Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[])
 {
   intptr_t fd = 0;

racket/src/racket/src/schminc.h

@@ -15,7 +15,7 @@
 #define USE_COMPILED_STARTUP 1
 
 #define EXPECTED_PRIM_COUNT 1160
-#define EXPECTED_UNSAFE_COUNT 150
+#define EXPECTED_UNSAFE_COUNT 156
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45
 #define EXPECTED_FUTURES_COUNT 15

racket/src/racket/src/schpriv.h

@@ -379,6 +379,7 @@ void scheme_init_exn(Scheme_Env *env);
 void scheme_init_debug(Scheme_Env *env);
 void scheme_init_thread(Scheme_Env *env);
 void scheme_init_unsafe_thread(Scheme_Env *env);
+void scheme_init_unsafe_port(Scheme_Env *env);
 void scheme_init_read(Scheme_Env *env);
 void scheme_init_print(Scheme_Env *env);
 #ifndef NO_SCHEME_THREADS

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.11.0.3"
+#define MZSCHEME_VERSION "6.11.0.4"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 11
 #define MZSCHEME_VERSION_Z 0
-#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)