Adding fcntl interface.

* configure: changing HAVE_FCNTL_H to HAVE_FCNTL.

* sysif.c (flock_s, type_s, whence_s, start_s, len_s, pid_s):
New symbol variables.
(flock_pack, flock_unpack, fcntl_wrap): New static functions.
(sysif_init): Initialize new symbol variables.
Create flock struct type.  Register new intrinsic variables:
o-accmode, o-rdonly, o-wronly, o-rdwr, o-creat, o-noctty,
o-trunc, o-append, o-nonblock, o-sync, o-async, o-directory,
o-nofollow, o-cloexec, o-direct, o-noatime, o-path, f-dupfd,
f-dupfd-cloexec, f-getfd, f-setfd, fd-cloexec, f-getfl,
f-setfl, f-getlk, f-setlk, f-setlkw, f-rdlck, f-wrlck,
f-unlck, seek-set, seek-cur and seek-end.
Register fcntl intrinsic function.

* txr.1: Documented.

3 files changed, 311 insertions, 2 deletions

diff --git a/configure b/configure
index 064ea3ee..18a24207 100755
--- a/configure
+++ b/configure
@@ -1736,7 +1736,7 @@ int main(int argc, char **argv)
 
 if conftest ; then
   printf "yes\n"
-  printf "#define HAVE_FCNTL_H 1\n" >> config.h
+  printf "#define HAVE_FCNTL 1\n" >> config.h
 else
   printf "no\n"
 fi
diff --git a/sysif.c b/sysif.c
index 808e0e91..07ca13e9 100644
--- a/sysif.c
+++ b/sysif.c
@@ -37,7 +37,7 @@
 #if HAVE_UNISTD_H
 #include <unistd.h>
 #endif
-#if HAVE_FCNTL_H
+#if HAVE_FCNTL
 #include <fcntl.h>
 #endif
 #if HAVE_SYS_WAIT
@@ -113,6 +113,10 @@ val utsname_s, sysname_s, nodename_s, release_s, version_s, machine_s;
 val domainname_s;
 #endif
 
+#if HAVE_FCNTL
+val flock_s, type_s, whence_s, start_s, len_s, pid_s;
+#endif
+
 #if HAVE_DLOPEN
 val dlhandle_s, dlsym_s;
 #endif
@@ -532,6 +536,72 @@ static val readlink_wrap(val path)
 
 #endif
 
+#if HAVE_FCNTL
+
+static void flock_pack(val self, val in, struct flock *out)
+{
+  out->l_type = c_short(slot(in, type_s), self);
+  out->l_whence = c_short(slot(in, whence_s), self);
+  out->l_start = c_num(slot(in, start_s));
+  out->l_len = c_num(slot(in, len_s));
+}
+
+static void flock_unpack(val self, val out, struct flock *in)
+{
+  slotset(out, type_s, num(in->l_type));
+  slotset(out, whence_s, num(in->l_whence));
+  slotset(out, start_s, num(in->l_start));
+  slotset(out, len_s, num(in->l_len));
+  slotset(out, pid_s, num(in->l_pid));
+}
+
+static val fcntl_wrap(val fd_in, val cmd_in, val arg_in)
+{
+  val self = lit("fcntl");
+  int fd = c_int(fd_in, self);
+  int cmd = c_int(cmd_in, self);
+  int res = -1;
+
+  switch (cmd) {
+  case F_DUPFD:
+#ifdef F_DUPFD_CLOEXEC
+  case F_DUPFD_CLOEXEC:
+#endif
+  case F_SETFD:
+  case F_SETFL:
+    if (missingp(arg_in)) {
+      errno = EINVAL;
+    } else {
+      long arg = c_long(arg_in, self);
+      res = fcntl(fd, cmd, arg);
+    }
+    break;
+  case F_GETFD:
+  case F_GETFL:
+    res = fcntl(fd, cmd);
+    break;
+  case F_SETLK:
+  case F_SETLKW:
+  case F_GETLK:
+    if (missingp(arg_in)) {
+      errno = EINVAL;
+    } else {
+      struct flock fl = { 0 };
+      flock_pack(self, arg_in, &fl);
+      res  = fcntl(fd, cmd, &fl);
+      if (cmd == F_GETLK)
+        flock_unpack(self, arg_in, &fl);
+    }
+  default:
+    errno = EINVAL;
+    break;
+  }
+
+  return num(res);
+}
+
+#endif
+
 #if HAVE_FORK_STUFF
 static val fork_wrap(void)
 {
@@ -1661,6 +1731,14 @@ void sysif_init(void)
   machine_s = intern(lit("machine"), user_package);
   domainname_s = intern(lit("domainname"), user_package);
 #endif
+#if HAVE_FCNTL
+  flock_s = intern(lit("flock"), user_package);
+  type_s = intern(lit("type"), user_package);
+  whence_s = intern(lit("whence"), user_package);
+  start_s = intern(lit("start"), user_package);
+  len_s = intern(lit("len"), user_package);
+  pid_s = intern(lit("pid"), user_package);
+#endif
 
   make_struct_type(stat_s, nil, nil,
                    list(dev_s, ino_s, mode_s, nlink_s, uid_s, gid_s,
@@ -1682,6 +1760,11 @@ void sysif_init(void)
                         version_s, machine_s, domainname_s, nao),
                    nil, nil, nil, nil);
 #endif
+#if HAVE_FCNTL
+  make_struct_type(flock_s, nil, nil,
+                   list(type_s, whence_s, start_s, len_s, pid_s, nao),
+                   nil, nil, nil, nil);
+#endif
 
   reg_fun(intern(lit("errno"), user_package), func_n1o(errno_wrap, 0));
   reg_fun(intern(lit("exit"), user_package), func_n1(exit_wrap));
@@ -1733,6 +1816,64 @@ void sysif_init(void)
   reg_fun(intern(lit("readlink"), user_package), func_n1(readlink_wrap));
 #endif
 
+#if HAVE_FCNTL
+  reg_varl(intern(lit("o-accmode"), user_package), num_fast(O_ACCMODE));
+  reg_varl(intern(lit("o-rdonly"), user_package), num_fast(O_RDONLY));
+  reg_varl(intern(lit("o-wronly"), user_package), num_fast(O_WRONLY));
+  reg_varl(intern(lit("o-rdwr"), user_package), num_fast(O_RDWR));
+  reg_varl(intern(lit("o-creat"), user_package), num_fast(O_CREAT));
+  reg_varl(intern(lit("o-noctty"), user_package), num_fast(O_NOCTTY));
+  reg_varl(intern(lit("o-trunc"), user_package), num_fast(O_TRUNC));
+  reg_varl(intern(lit("o-append"), user_package), num_fast(O_APPEND));
+  reg_varl(intern(lit("o-nonblock"), user_package), num_fast(O_NONBLOCK));
+  reg_varl(intern(lit("o-sync"), user_package), num_fast(O_SYNC));
+#ifdef O_ASYNC
+  reg_varl(intern(lit("o-async"), user_package), num_fast(O_ASYNC));
+#endif
+#ifdef O_DIRECTORY
+  reg_varl(intern(lit("o-directory"), user_package), num_fast(O_DIRECTORY));
+#endif
+#ifdef O_NOFOLLOW
+  reg_varl(intern(lit("o-nofollow"), user_package), num_fast(O_NOFOLLOW));
+#endif
+#ifdef O_CLOEXEC
+  reg_varl(intern(lit("o-cloexec"), user_package), num_fast(O_CLOEXEC));
+#endif
+#ifdef O_DIRECT
+  reg_varl(intern(lit("o-direct"), user_package), num_fast(O_DIRECT));
+#endif
+#ifdef O_NOATIME
+  reg_varl(intern(lit("o-noatime"), user_package), num_fast(O_NOATIME));
+#endif
+#ifdef O_PATH
+  reg_varl(intern(lit("o-path"), user_package), num_fast(O_PATH));
+#endif
+
+  reg_varl(intern(lit("f-dupfd"), user_package), num_fast(F_DUPFD));
+#ifdef F_DUPFD_CLOEXEC
+  reg_varl(intern(lit("f-dupfd-cloexec"), user_package), num_fast(F_DUPFD_CLOEXEC));
+#endif
+  reg_varl(intern(lit("f-getfd"), user_package), num_fast(F_GETFD));
+  reg_varl(intern(lit("f-setfd"), user_package), num_fast(F_SETFD));
+
+  reg_varl(intern(lit("fd-cloexec"), user_package), num_fast(FD_CLOEXEC));
+
+  reg_varl(intern(lit("f-getfl"), user_package), num_fast(F_GETFL));
+  reg_varl(intern(lit("f-setfl"), user_package), num_fast(F_SETFL));
+
+  reg_varl(intern(lit("f-getlk"), user_package), num_fast(F_GETLK));
+  reg_varl(intern(lit("f-setlk"), user_package), num_fast(F_SETLK));
+  reg_varl(intern(lit("f-setlkw"), user_package), num_fast(F_SETLKW));
+  reg_varl(intern(lit("f-rdlck"), user_package), num_fast(F_RDLCK));
+  reg_varl(intern(lit("f-wrlck"), user_package), num_fast(F_WRLCK));
+  reg_varl(intern(lit("f-unlck"), user_package), num_fast(F_UNLCK));
+  reg_varl(intern(lit("seek-set"), user_package), num_fast(SEEK_SET));
+  reg_varl(intern(lit("seek-cur"), user_package), num_fast(SEEK_CUR));
+  reg_varl(intern(lit("seek-end"), user_package), num_fast(SEEK_END));
+
+  reg_fun(intern(lit("fcntl"), user_package), func_n3o(fcntl_wrap, 2));
+#endif
+
   reg_fun(intern(lit("stat"), user_package), func_n1(statp));
   reg_fun(intern(lit("lstat"), user_package), func_n1(statl));
   reg_fun(intern(lit("fstat"), user_package), func_n1(statf));
diff --git a/txr.1 b/txr.1
index a2d0a50d..7408f181 100644
--- a/txr.1
+++ b/txr.1
@@ -54815,6 +54815,174 @@ only entries which polled positive. The
 .code cdr
 of every pair now holds a bitmask of the events which were to have occurred.
 
+.SS* Unix File Control
+
+.coNP Variables @, o-accmode @, o-rdonly @, o-wronly @, o-rdwr @, o-creat @, o-noctty @, o-trunc @, o-append @, o-nonblock @, o-sync @, o-async @, o-directory @, o-nofollow @, o-cloexec @, o-direct @ o-noatime and @ o-path
+.desc
+These variables correspond to the POSIX file mode constants
+.codn O_ACCMODE ,
+.codn O_RDONLY ,
+.codn O_WRONLY ,
+.codn O_RDWR ,
+.codn O_CREAT ,
+.codn O_NOCTTY ,
+and so forth.
+
+The availability of the variables
+.codn o-async ,
+.codn o-directory ,
+.codn o-nofollow ,
+.codn o-cloexec ,
+.codn o-direct ,
+.code o-noatime
+and
+.code o-path
+depends on the host platform.
+
+Some of these flags may be set or cleared on an existing file descriptor
+using the
+.code f-setfl
+command of the
+.code fcntl
+function, in accordance with POSIX and the host platform documentation.
+
+.coNP Variables @, seek-set @ seek-cur and @ seek-end
+.desc
+These variables correspond to the ISO C constants
+.codn SEEK_SET ,
+.code SEEK_CUR
+and
+.codn SEEK_END .
+These values, usually associated with the ISO C
+.code fseek
+function, are also used in the
+.code fcntl
+file locking interface as values of the
+.code whence
+member of the
+.code flock
+structure.
+
+.coNP Variables @, f-dupfd @, f-dupfd-cloexec @, f-getfd @, f-setfd @, f-getfl @, f-setfl @, f-getlk @ f-setlk and @ f-setlkw
+.desc
+These variables correspond to the POSIX
+.code fcntl
+command constants
+.codn F_DUPFD ,
+.codn F_GETFD ,
+.codn F_SETFD ,
+and so forth. Availability of the
+.code f-dupfd-cloexec
+depends on the host platform.
+
+.coNP Variable @ fd-cloexec
+.desc
+The
+.code fd-cloexec
+variable corresponds to the POSIX
+.code FD_CLOEXEC
+constant. It denotes the flag which may  be set by the
+.code fd-setfd
+command of the
+.code fcntl
+function.
+
+.coNP Variables @, f-rdlck @ f-wrlck and @ f-unlck
+.desc
+These variables correspond to the POSIX lock type constants
+.codn F_RDLCK ,
+.code F_WRLCK
+and
+.codn F_UNLCK .
+They specify the possible values of the
+.code type
+field of the
+.code flock
+structure.
+
+.coNP Structure @ flock
+.synb
+.mets (defstruct flock nil
+.mets \ \  type whence
+.mets \ \  start len
+.mets \ \  pid)
+.syne
+.desc
+The
+.code flock
+structure corresponds to the POSIX structure of the same name.
+An instance of this structure must be specified as the third
+argument of the
+.code fcntl
+function when the
+.meta command
+argument is one of the values
+.codn f-getlk ,
+.code f-setlk
+or
+.codn f-setlkw .
+
+All slots must be initialized with appropriate values before
+calling
+.code fcntl
+with the exception that the
+.code f-getlk
+command does not access the existing value of the
+.code pid
+slot.
+
+.coNP Function @ fcntl
+.synb
+.mets (fcntl < fileno < command <> [ arg ])
+.syne
+.desc
+The
+.code fcntl
+function corresponds to the same-named POSIX function.
+The
+.meta fileno
+and
+.meta command
+arguments must be integers.
+The \*(TL
+.code fileno
+restricts the
+.meta command
+argument to the supported values for which symbolic variable names are provided.
+Other integer
+.meta command
+values are rejected by returning -1 and setting the
+.code errno
+variable to
+.codn EINVAL .
+Whether the third argument is required, and what type it must be, depends on the
+.meta command
+value. Commands not requiring the third argument ignore it if it is passed.
+
+.code fcntl
+commands for which POSIX requires an argument of type
+.code long
+require
+.meta arg
+to be an integer.
+
+The file locking commands
+.codn f-getlk ,
+.code f-setlk
+and
+.code f-setlkw
+require
+.meta arg
+to be a
+.code flock
+structure.
+
+The
+.code fcntl
+function doesn't throw an error if the underlying POSIX function indicates
+failure; the underlying function's return value is converted to a Lisp integer
+and returned.
+
 .SS* Unix Itimers
 Itimers ("interval timers") can be used in combination with signal handling to
 execute asynchronous actions. Itimers deliver delayed, one-time signals,