diff options
Diffstat (limited to 'ghc/runtime/io')
36 files changed, 3466 insertions, 0 deletions
diff --git a/ghc/runtime/io/closeFile.lc b/ghc/runtime/io/closeFile.lc new file mode 100644 index 0000000000..f3efb3488d --- /dev/null +++ b/ghc/runtime/io/closeFile.lc @@ -0,0 +1,32 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[closeFile.lc]{hClose Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +closeFile(fp) +StgAddr fp; +{ + int rc; + + unlockFile(fileno((FILE *) fp)); + + while ((rc = fclose((FILE *) fp)) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return rc; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/runtime/io/createDirectory.lc b/ghc/runtime/io/createDirectory.lc new file mode 100644 index 0000000000..759e99c998 --- /dev/null +++ b/ghc/runtime/io/createDirectory.lc @@ -0,0 +1,58 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[createDirectory.lc]{createDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +StgInt +createDirectory(path) +StgByteArray path; +{ + int rc; + struct stat sb; + + while((rc = mkdir(path, 0777)) != 0) { + if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOENT: + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to directory"; + break; + case GHC_EEXIST: + if (stat(path, &sb) != 0) { + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "cannot stat existing file"; + } + if (S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "directory already exists"; + } else { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "file already exists"; + } + break; + } + return -1; + } + } + return 0; +} + +\end{code} diff --git a/ghc/runtime/io/env.lc b/ghc/runtime/io/env.lc new file mode 100644 index 0000000000..2e26595657 --- /dev/null +++ b/ghc/runtime/io/env.lc @@ -0,0 +1,166 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[env.lc]{Environment Handling for LibPosix} + +Many useful environment functions are not necessarily provided by libc. +To get around this problem, we introduce our own. The first time that +you modify your environment, we copy the environment wholesale into +malloc'ed locations, so that subsequent modifications can do proper +memory management. The $environ$ variable is updated with a pointer +to the current environment so that the normal $getenv$ and $exec*$ functions +should continue to work properly. + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "libposix.h" + +/* Switch this on once we've moved the environment to the malloc arena */ +int dirtyEnv = 0; + +/* + * For some reason, OSF turns off the prototype for this if we're _POSIX_SOURCE. + * Seems to me that this ought to be an ANSI-ism rather than a POSIX-ism, + * but no matter. + */ + +char * +strdup(const char *src) +{ + int len = strlen(src) + 1; + char *dst; + + if ((dst = malloc(len)) != NULL) + memcpy(dst, src, len); + return dst; +} + +/* Replace the entire environment */ +int +setenviron(envp) +char **envp; +{ + char **old = environ; + int dirtyOld = dirtyEnv; + int i; + + /* A quick hack to move the strings out of the heap */ + environ = envp; + if (copyenv() != 0) { + environ = old; + return -1; + } + /* Release the old space if we allocated it ourselves earlier */ + if (dirtyOld) { + for (i = 0; old[i] != NULL; i++) + free(old[i]); + free(old); + } + return 0; +} + +/* Copy initial environment into malloc arena */ +int +copyenv() +{ + char **new; + int i; + + for (i = 0; environ[i] != NULL; i++); + + if ((new = (char **) malloc((i + 1) * sizeof(char *))) == NULL) + return -1; + + new[i] = NULL; + + while (--i >= 0) { + if ((new[i] = strdup(environ[i])) == NULL) { + while (new[++i] != NULL) + free(new[i]); + free(new); + return -1; + } + } + environ = new; + dirtyEnv = 1; + return 0; +} + +/* Set or replace an environment variable */ +int +setenv(mapping) +char *mapping; +{ + int i, keylen; + char *p; + char **new; + + /* We must have a non-empty key and an '=' */ + if (mapping[0] == '=' || (p = strchr(mapping, '=')) == NULL) { + errno = EINVAL; + return -1; + } + /* Include through the '=' for matching */ + keylen = p - mapping + 1; + + if (!dirtyEnv && copyenv() != 0) + return -1; + + if ((p = strdup(mapping)) == NULL) + return -1; + + /* Look for an existing key that matches */ + for (i = 0; environ[i] != NULL && strncmp(environ[i], p, keylen) != 0; i++); + + if (environ[i] != NULL) { + free(environ[i]); + environ[i] = p; + } else { + if ((new = (char **) realloc(environ, (i + 1) * sizeof(char *))) == NULL) { + free(p); + return -1; + } + new[i] = p; + new[i + 1] = NULL; + environ = new; + } + return 0; +} + +/* Delete a variable from the environment */ +int +delenv(name) +char *name; +{ + int i, keylen; + + if (strchr(name, '=') != NULL) { + errno = EINVAL; + return -1; + } + keylen = strlen(name); + + if (!dirtyEnv && copyenv() != 0) + return -1; + + /* Look for a matching key */ + for (i = 0; environ[i] != NULL && + (strncmp(environ[i], name, keylen) != 0 || environ[i][keylen] != '='); i++); + + /* Don't complain if it wasn't there to begin with */ + if (environ[i] == NULL) { + return 0; + } + free(environ[i]); + + do { + environ[i] = environ[i + 1]; + i++; + } while (environ[i] != NULL); + + return 0; +} + +\end{code} diff --git a/ghc/runtime/io/errno.lc b/ghc/runtime/io/errno.lc new file mode 100644 index 0000000000..24ea25d088 --- /dev/null +++ b/ghc/runtime/io/errno.lc @@ -0,0 +1,925 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[errno.lc]{GHC Error Number Conversion} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +int ghc_errno = 0; +int ghc_errtype = 0; + +char *ghc_errstr = NULL; + +/* Collect all of the grotty #ifdef's in one place. */ + +void cvtErrno(STG_NO_ARGS) +{ + switch(errno) { +#ifdef E2BIG + case E2BIG: + ghc_errno = GHC_E2BIG; + break; +#endif +#ifdef EACCES + case EACCES: + ghc_errno = GHC_EACCES; + break; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: + ghc_errno = GHC_EADDRINUSE; + break; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: + ghc_errno = GHC_EADDRNOTAVAIL; + break; +#endif +#ifdef EADV + case EADV: + ghc_errno = GHC_EADV; + break; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: + ghc_errno = GHC_EAFNOSUPPORT; + break; +#endif +#ifdef EAGAIN + case EAGAIN: + ghc_errno = GHC_EAGAIN; + break; +#endif +#ifdef EALREADY + case EALREADY: + ghc_errno = GHC_EALREADY; + break; +#endif +#ifdef EBADF + case EBADF: + ghc_errno = GHC_EBADF; + break; +#endif +#ifdef EBADMSG + case EBADMSG: + ghc_errno = GHC_EBADMSG; + break; +#endif +#ifdef EBADRPC + case EBADRPC: + ghc_errno = GHC_EBADRPC; + break; +#endif +#ifdef EBUSY + case EBUSY: + ghc_errno = GHC_EBUSY; + break; +#endif +#ifdef ECHILD + case ECHILD: + ghc_errno = GHC_ECHILD; + break; +#endif +#ifdef ECOMM + case ECOMM: + ghc_errno = GHC_ECOMM; + break; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: + ghc_errno = GHC_ECONNABORTED; + break; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: + ghc_errno = GHC_ECONNREFUSED; + break; +#endif +#ifdef ECONNRESET + case ECONNRESET: + ghc_errno = GHC_ECONNRESET; + break; +#endif +#ifdef EDEADLK + case EDEADLK: + ghc_errno = GHC_EDEADLK; + break; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: + ghc_errno = GHC_EDESTADDRREQ; + break; +#endif +#ifdef EDIRTY + case EDIRTY: + ghc_errno = GHC_EDIRTY; + break; +#endif +#ifdef EDOM + case EDOM: + ghc_errno = GHC_EDOM; + break; +#endif +#ifdef EDQUOT + case EDQUOT: + ghc_errno = GHC_EDQUOT; + break; +#endif +#ifdef EEXIST + case EEXIST: + ghc_errno = GHC_EEXIST; + break; +#endif +#ifdef EFAULT + case EFAULT: + ghc_errno = GHC_EFAULT; + break; +#endif +#ifdef EFBIG + case EFBIG: + ghc_errno = GHC_EFBIG; + break; +#endif +#ifdef EFTYPE + case EFTYPE: + ghc_errno = GHC_EFTYPE; + break; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: + ghc_errno = GHC_EHOSTDOWN; + break; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: + ghc_errno = GHC_EHOSTUNREACH; + break; +#endif +#ifdef EIDRM + case EIDRM: + ghc_errno = GHC_EIDRM; + break; +#endif +#ifdef EILSEQ + case EILSEQ: + ghc_errno = GHC_EILSEQ; + break; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: + ghc_errno = GHC_EINPROGRESS; + break; +#endif +#ifdef EINTR + case EINTR: + ghc_errno = GHC_EINTR; + break; +#endif +#ifdef EINVAL + case EINVAL: + ghc_errno = GHC_EINVAL; + break; +#endif +#ifdef EIO + case EIO: + ghc_errno = GHC_EIO; + break; +#endif +#ifdef EISCONN + case EISCONN: + ghc_errno = GHC_EISCONN; + break; +#endif +#ifdef EISDIR + case EISDIR: + ghc_errno = GHC_EISDIR; + break; +#endif +#ifdef ELOOP + case ELOOP: + ghc_errno = GHC_ELOOP; + break; +#endif +#ifdef EMFILE + case EMFILE: + ghc_errno = GHC_EMFILE; + break; +#endif +#ifdef EMLINK + case EMLINK: + ghc_errno = GHC_EMLINK; + break; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: + ghc_errno = GHC_EMSGSIZE; + break; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: + ghc_errno = GHC_EMULTIHOP; + break; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: + ghc_errno = GHC_ENAMETOOLONG; + break; +#endif +#ifdef ENETDOWN + case ENETDOWN: + ghc_errno = GHC_ENETDOWN; + break; +#endif +#ifdef ENETRESET + case ENETRESET: + ghc_errno = GHC_ENETRESET; + break; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: + ghc_errno = GHC_ENETUNREACH; + break; +#endif +#ifdef ENFILE + case ENFILE: + ghc_errno = GHC_ENFILE; + break; +#endif +#ifdef ENOBUFS + case ENOBUFS: + ghc_errno = GHC_ENOBUFS; + break; +#endif +#ifdef ENODATA + case ENODATA: + ghc_errno = GHC_ENODATA; + break; +#endif +#ifdef ENODEV + case ENODEV: + ghc_errno = GHC_ENODEV; + break; +#endif +#ifdef ENOENT + case ENOENT: + ghc_errno = GHC_ENOENT; + break; +#endif +#ifdef ENOEXEC + case ENOEXEC: + ghc_errno = GHC_ENOEXEC; + break; +#endif +#ifdef ENOLCK + case ENOLCK: + ghc_errno = GHC_ENOLCK; + break; +#endif +#ifdef ENOLINK + case ENOLINK: + ghc_errno = GHC_ENOLINK; + break; +#endif +#ifdef ENOMEM + case ENOMEM: + ghc_errno = GHC_ENOMEM; + break; +#endif +#ifdef ENOMSG + case ENOMSG: + ghc_errno = GHC_ENOMSG; + break; +#endif +#ifdef ENONET + case ENONET: + ghc_errno = GHC_ENONET; + break; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: + ghc_errno = GHC_ENOPROTOOPT; + break; +#endif +#ifdef ENOSPC + case ENOSPC: + ghc_errno = GHC_ENOSPC; + break; +#endif +#ifdef ENOSR + case ENOSR: + ghc_errno = GHC_ENOSR; + break; +#endif +#ifdef ENOSTR + case ENOSTR: + ghc_errno = GHC_ENOSTR; + break; +#endif +#ifdef ENOSYS + case ENOSYS: + ghc_errno = GHC_ENOSYS; + break; +#endif +#ifdef ENOTBLK + case ENOTBLK: + ghc_errno = GHC_ENOTBLK; + break; +#endif +#ifdef ENOTCONN + case ENOTCONN: + ghc_errno = GHC_ENOTCONN; + break; +#endif +#ifdef ENOTDIR + case ENOTDIR: + ghc_errno = GHC_ENOTDIR; + break; +#endif +#ifdef ENOTEMPTY + case ENOTEMPTY: + ghc_errno = GHC_ENOTEMPTY; + break; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: + ghc_errno = GHC_ENOTSOCK; + break; +#endif +#ifdef ENOTTY + case ENOTTY: + ghc_errno = GHC_ENOTTY; + break; +#endif +#ifdef ENXIO + case ENXIO: + ghc_errno = GHC_ENXIO; + break; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: + ghc_errno = GHC_EOPNOTSUPP; + break; +#endif +#ifdef EPERM + case EPERM: + ghc_errno = GHC_EPERM; + break; +#endif +#ifdef EPFNOSUPPORT + case EPFNOSUPPORT: + ghc_errno = GHC_EPFNOSUPPORT; + break; +#endif +#ifdef EPIPE + case EPIPE: + ghc_errno = GHC_EPIPE; + break; +#endif +#ifdef EPROCLIM + case EPROCLIM: + ghc_errno = GHC_EPROCLIM; + break; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: + ghc_errno = GHC_EPROCUNAVAIL; + break; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: + ghc_errno = GHC_EPROGMISMATCH; + break; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: + ghc_errno = GHC_EPROGUNAVAIL; + break; +#endif +#ifdef EPROTO + case EPROTO: + ghc_errno = GHC_EPROTO; + break; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: + ghc_errno = GHC_EPROTONOSUPPORT; + break; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: + ghc_errno = GHC_EPROTOTYPE; + break; +#endif +#ifdef ERANGE + case ERANGE: + ghc_errno = GHC_ERANGE; + break; +#endif +#ifdef EREMCHG + case EREMCHG: + ghc_errno = GHC_EREMCHG; + break; +#endif +#ifdef EREMOTE + case EREMOTE: + ghc_errno = GHC_EREMOTE; + break; +#endif +#ifdef EROFS + case EROFS: + ghc_errno = GHC_EROFS; + break; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: + ghc_errno = GHC_ERPCMISMATCH; + break; +#endif +#ifdef ERREMOTE + case ERREMOTE: + ghc_errno = GHC_ERREMOTE; + break; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: + ghc_errno = GHC_ESHUTDOWN; + break; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: + ghc_errno = GHC_ESOCKTNOSUPPORT; + break; +#endif +#ifdef ESPIPE + case ESPIPE: + ghc_errno = GHC_ESPIPE; + break; +#endif +#ifdef ESRCH + case ESRCH: + ghc_errno = GHC_ESRCH; + break; +#endif +#ifdef ESRMNT + case ESRMNT: + ghc_errno = GHC_ESRMNT; + break; +#endif +#ifdef ESTALE + case ESTALE: + ghc_errno = GHC_ESTALE; + break; +#endif +#ifdef ETIME + case ETIME: + ghc_errno = GHC_ETIME; + break; +#endif +#ifdef ETIMEDOUT + case ETIMEDOUT: + ghc_errno = GHC_ETIMEDOUT; + break; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: + ghc_errno = GHC_ETOOMANYREFS; + break; +#endif +#ifdef ETXTBSY + case ETXTBSY: + ghc_errno = GHC_ETXTBSY; + break; +#endif +#ifdef EUSERS + case EUSERS: + ghc_errno = GHC_EUSERS; + break; +#endif +#if 0 +#ifdef EWOULDBLOCK + case EWOULDBLOCK: + ghc_errno = GHC_EWOULDBLOCK; + break; +#endif +#endif +#ifdef EXDEV + case EXDEV: + ghc_errno = GHC_EXDEV; + break; +#endif + default: + ghc_errno = errno; + break; + } +} + +void +stdErrno(STG_NO_ARGS) +{ + switch(ghc_errno) { + default: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "unexpected error"; + break; + case 0: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "no error"; + case GHC_E2BIG: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "argument list too long"; + break; + case GHC_EACCES: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "inadequate access permission"; + break; + case GHC_EADDRINUSE: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "address already in use"; + break; + case GHC_EADDRNOTAVAIL: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "address not available"; + break; + case GHC_EADV: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "RFS advertise error"; + break; + case GHC_EAFNOSUPPORT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "address family not supported by protocol family"; + break; + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "insufficient resources"; + break; + case GHC_EALREADY: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "operation already in progress"; + break; + case GHC_EBADF: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "internal error (EBADF)"; + break; + case GHC_EBADMSG: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "next message has wrong type"; + break; + case GHC_EBADRPC: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "invalid RPC request or response"; + break; + case GHC_EBUSY: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "device busy"; + break; + case GHC_ECHILD: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no child processes"; + break; + case GHC_ECOMM: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "no virtual circuit could be found"; + break; + case GHC_ECONNABORTED: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "aborted connection"; + break; + case GHC_ECONNREFUSED: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no listener on remote host"; + break; + case GHC_ECONNRESET: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "connection reset by peer"; + break; + case GHC_EDEADLK: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "resource deadlock avoided"; + break; + case GHC_EDESTADDRREQ: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "destination address required"; + break; + case GHC_EDIRTY: + ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; + ghc_errstr = "file system dirty"; + break; + case GHC_EDOM: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "argument too large"; + break; + case GHC_EDQUOT: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "quota exceeded"; + break; + case GHC_EEXIST: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "file already exists"; + break; + case GHC_EFAULT: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "internal error (EFAULT)"; + break; + case GHC_EFBIG: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "file too large"; + break; + case GHC_EFTYPE: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "inappropriate NFS file type or format"; + break; + case GHC_EHOSTDOWN: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "destination host down"; + break; + case GHC_EHOSTUNREACH: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "remote host is unreachable"; + break; + case GHC_EIDRM: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "IPC identifier removed"; + break; + case GHC_EILSEQ: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "invalid wide character"; + break; + case GHC_EINPROGRESS: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "operation now in progress"; + break; + case GHC_EINTR: + ghc_errtype = ERR_INTERRUPTED; + ghc_errstr = "interrupted system call"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "invalid argument"; + break; + case GHC_EIO: + ghc_errtype = ERR_HARDWAREFAULT; + ghc_errstr = "unknown I/O fault"; + break; + case GHC_EISCONN: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "socket is already connected"; + break; + case GHC_EISDIR: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "file is a directory"; + break; + case GHC_ELOOP: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "too many symbolic links"; + break; + case GHC_EMFILE: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "process file table full"; + break; + case GHC_EMLINK: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "too many links"; + break; + case GHC_EMSGSIZE: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "message too long"; + break; + case GHC_EMULTIHOP: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "multi-hop RFS request"; + break; + case GHC_ENAMETOOLONG: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "filename too long"; + break; + case GHC_ENETDOWN: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "network is down"; + break; + case GHC_ENETRESET: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "remote host rebooted; connection lost"; + break; + case GHC_ENETUNREACH: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "remote network is unreachable"; + break; + case GHC_ENFILE: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "system file table full"; + break; + case GHC_ENOBUFS: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "no buffer space available"; + break; + case GHC_ENODATA: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no message on the stream head read queue"; + break; + case GHC_ENODEV: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such device"; + break; + case GHC_ENOENT: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such file or directory"; + break; + case GHC_ENOEXEC: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not an executable file"; + break; + case GHC_ENOLCK: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "no file locks available"; + break; + case GHC_ENOLINK: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "RFS link has been severed"; + break; + case GHC_ENOMEM: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "not enough virtual memory"; + break; + case GHC_ENOMSG: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no message of desired type"; + break; + case GHC_ENONET: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "host is not on a network"; + break; + case GHC_ENOPROTOOPT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "operation not supported by protocol"; + break; + case GHC_ENOSPC: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "no space left on device"; + break; + case GHC_ENOSR: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "out of stream resources"; + break; + case GHC_ENOSTR: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not a stream device"; + break; + case GHC_ENOSYS: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "function not implemented"; + break; + case GHC_ENOTBLK: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not a block device"; + break; + case GHC_ENOTCONN: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "socket is not connected"; + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "not a directory"; + break; + case GHC_ENOTEMPTY: + ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; + ghc_errstr = "directory not empty"; + break; + case GHC_ENOTSOCK: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not a socket"; + break; + case GHC_ENOTTY: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "inappropriate ioctl for device"; + break; + case GHC_ENXIO: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such device or address"; + break; + case GHC_EOPNOTSUPP: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "operation not supported on socket"; + break; + case GHC_EPERM: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "privileged operation"; + break; + case GHC_EPFNOSUPPORT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "protocol family not supported"; + break; + case GHC_EPIPE: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "broken pipe"; + break; + case GHC_EPROCLIM: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "too many processes"; + break; + case GHC_EPROCUNAVAIL: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "unimplemented RPC procedure"; + break; + case GHC_EPROGMISMATCH: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "unsupported RPC program version"; + break; + case GHC_EPROGUNAVAIL: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "RPC program unavailable"; + break; + case GHC_EPROTO: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "error in streams protocol"; + break; + case GHC_EPROTONOSUPPORT: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "protocol not supported"; + break; + case GHC_EPROTOTYPE: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "wrong protocol for socket"; + break; + case GHC_ERANGE: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "result too large"; + break; + case GHC_EREMCHG: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "remote address changed"; + break; + case GHC_EREMOTE: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "too many levels of remote in path"; + break; + case GHC_EROFS: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "read-only file system"; + break; + case GHC_ERPCMISMATCH: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "RPC version is wrong"; + break; + case GHC_ERREMOTE: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "object is remote"; + break; + case GHC_ESHUTDOWN: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "can't send after socket shutdown"; + break; + case GHC_ESOCKTNOSUPPORT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "socket type not supported"; + break; + case GHC_ESPIPE: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't seek on a pipe"; + break; + case GHC_ESRCH: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such process"; + break; + case GHC_ESRMNT: + ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; + ghc_errstr = "RFS resources still mounted by remote host(s)"; + break; + case GHC_ESTALE: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "stale NFS file handle"; + break; + case GHC_ETIME: + ghc_errtype = ERR_TIMEEXPIRED; + ghc_errstr = "timer expired"; + break; + case GHC_ETIMEDOUT: + ghc_errtype = ERR_TIMEEXPIRED; + ghc_errstr = "connection timed out"; + break; + case GHC_ETOOMANYREFS: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "too many references; can't splice"; + break; + case GHC_ETXTBSY: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "text file in-use"; + break; + case GHC_EUSERS: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "quota table full"; + break; + case GHC_EWOULDBLOCK: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "operation would block"; + break; + case GHC_EXDEV: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't make a cross-device link"; + break; + } +} + +\end{code} diff --git a/ghc/runtime/io/execvpe.lc b/ghc/runtime/io/execvpe.lc new file mode 100644 index 0000000000..522df19113 --- /dev/null +++ b/ghc/runtime/io/execvpe.lc @@ -0,0 +1,154 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[posix.lc]{executeFile Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "libposix.h" + +/* + * We want the search semantics of execvp, but we want to provide our + * own environment, like execve. The following copyright applies to + * this code, as it is a derivative of execvp: + *- + * Copyright (c) 1991 The Regents of the University of California. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +int +execvpe(name, argv, envp) +char *name; +char **argv; +char **envp; +{ + register int lp, ln; + register char *p; + int eacces, etxtbsy; + char *bp, *cur, *path, *buf; + + /* If it's an absolute or relative path name, it's easy. */ + if (strchr(name, '/')) { + bp = (char *) name; + cur = path = buf = NULL; + goto retry; + } + + /* Get the path we're searching. */ + if (!(path = getenv("PATH"))) { +#ifdef HAVE_CONFSTR + ln = confstr(_CS_PATH, NULL, 0); + if ((cur = path = malloc(ln + 1)) != NULL) { + path[0] = ':'; + (void) confstr (_CS_PATH, path + 1, ln); + } +#else + if ((cur = path = malloc(1 + 1)) != NULL) { + path[0] = ':'; + path[1] = '\0'; + } +#endif + } else + cur = path = strdup(path); + + if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL) + goto done; + + eacces = etxtbsy = 0; + while (cur != NULL) { + p = cur; + if ((cur = strchr(cur, ':')) != NULL) + *cur++ = '\0'; + + /* + * It's a SHELL path -- double, leading and trailing colons mean the current + * directory. + */ + if (!*p) { + p = "."; + lp = 1; + } else + lp = strlen(p); + ln = strlen(name); + + memcpy(buf, p, lp); + buf[lp] = '/'; + memcpy(buf + lp + 1, name, ln); + buf[lp + ln + 1] = '\0'; + + retry: + (void) execve(bp, argv, envp); + switch (errno) { + case EACCES: + eacces = 1; + break; + case ENOENT: + break; + case ENOEXEC: + { + register size_t cnt; + register char **ap; + + for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt) + ; + if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) { + memcpy(ap + 2, argv + 1, cnt * sizeof(char *)); + + ap[0] = "sh"; + ap[1] = bp; + (void) execve("/bin/sh", ap, envp); + free(ap); + } + goto done; + } + case ETXTBSY: + if (etxtbsy < 3) + (void) sleep(++etxtbsy); + goto retry; + default: + goto done; + } + } + if (eacces) + errno = EACCES; + else if (!errno) + errno = ENOENT; + done: + if (path) + free(path); + if (buf) + free(buf); + return (-1); +} + +\end{code} diff --git a/ghc/runtime/io/fileEOF.lc b/ghc/runtime/io/fileEOF.lc new file mode 100644 index 0000000000..81128d4d9c --- /dev/null +++ b/ghc/runtime/io/fileEOF.lc @@ -0,0 +1,23 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileEOF.lc]{hIsEOF Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +fileEOF(fp) +StgAddr fp; +{ + if (fileLookAhead(fp) != EOF) + return 0; + else if (ghc_errtype == ERR_EOF) + return 1; + else + return -1; +} + +\end{code} diff --git a/ghc/runtime/io/fileGetc.lc b/ghc/runtime/io/fileGetc.lc new file mode 100644 index 0000000000..336c0d9a7c --- /dev/null +++ b/ghc/runtime/io/fileGetc.lc @@ -0,0 +1,38 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileGetc.lc]{hGetChar Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "error.h" + +StgInt +fileGetc(fp) +StgAddr fp; +{ + int c; + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return EOF; + } + + /* Try to read a character */ + while ((c = getc((FILE *) fp)) == EOF && errno == EINTR) + clearerr((FILE *) fp); + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + } else if (c == EOF) { + cvtErrno(); + stdErrno(); + } + return c; +} + +\end{code} diff --git a/ghc/runtime/io/fileLookAhead.lc b/ghc/runtime/io/fileLookAhead.lc new file mode 100644 index 0000000000..df0d332ca7 --- /dev/null +++ b/ghc/runtime/io/fileLookAhead.lc @@ -0,0 +1,27 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileLookAhead.lc]{hLookAhead Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +fileLookAhead(fp) +StgAddr fp; +{ + int c; + + if ((c = fileGetc(fp)) == EOF) { + return c; + } else if (ungetc(c, (FILE *) fp) == EOF) { + cvtErrno(); + stdErrno(); + return EOF; + } else + return c; +} + +\end{code} diff --git a/ghc/runtime/io/filePosn.lc b/ghc/runtime/io/filePosn.lc new file mode 100644 index 0000000000..826c4f48b3 --- /dev/null +++ b/ghc/runtime/io/filePosn.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[filePosn.lc]{hGetPosn and hSetPosn Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +getFilePosn(fp) +StgAddr fp; +{ + StgInt posn; + + while ((posn = ftell((FILE *) fp)) == -1) { + /* the possibility seems awfully remote */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return posn; +} + +/* The following is only called with a position that we've already visited */ + +StgInt +setFilePosn(fp, posn) +StgAddr fp; +StgInt posn; +{ + while (fseek((FILE *) fp, posn, SEEK_SET) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/runtime/io/filePutc.lc b/ghc/runtime/io/filePutc.lc new file mode 100644 index 0000000000..bca57bafbe --- /dev/null +++ b/ghc/runtime/io/filePutc.lc @@ -0,0 +1,32 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[filePuc.lc]{hPutChar Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "error.h" + +StgInt +filePutc(fp, c) +StgAddr fp; +StgInt c; +{ + int rc; + + /* Try to read a character */ + while ((rc = putc((int) c, (FILE *) fp)) == EOF && errno == EINTR) + clearerr((FILE *) fp); + + if (rc == EOF) { + cvtErrno(); + stdErrno(); + return -1; + } + + return 0; +} + +\end{code} diff --git a/ghc/runtime/io/fileSize.lc b/ghc/runtime/io/fileSize.lc new file mode 100644 index 0000000000..ed3da3c77a --- /dev/null +++ b/ghc/runtime/io/fileSize.lc @@ -0,0 +1,45 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileSize.lc]{hfileSize Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +StgInt +fileSize(fp, result) +StgAddr fp; +StgByteArray result; +{ + struct stat sb; + + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (S_ISREG(sb.st_mode)) { + /* result will be word aligned */ + *(off_t *) result = sb.st_size; + return 0; + } else { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "not a regular file"; + return -1; + } +} + +\end{code} diff --git a/ghc/runtime/io/flushFile.lc b/ghc/runtime/io/flushFile.lc new file mode 100644 index 0000000000..68aa4456c5 --- /dev/null +++ b/ghc/runtime/io/flushFile.lc @@ -0,0 +1,30 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[flushFile.lc]{hFlush Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +flushFile(fp) +StgAddr fp; +{ + int rc; + + while ((rc = fflush((FILE *) fp)) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return rc; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/runtime/io/getBufferMode.lc b/ghc/runtime/io/getBufferMode.lc new file mode 100644 index 0000000000..0c6bb44b70 --- /dev/null +++ b/ghc/runtime/io/getBufferMode.lc @@ -0,0 +1,52 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[getBufferMode.lc]{hIs...Buffered Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +/* + * We try to guess what the default buffer mode is going to be based + * on the type of file we're attached to. + */ + +#define GBM_NB (0) +#define GBM_LB (-1) +#define GBM_BB (-2) +#define GBM_ERR (-3) + +StgInt +getBufferMode(fp) +StgAddr fp; +{ + struct stat sb; + + /* Try to find out the file type */ + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return GBM_ERR; + } + } + /* Terminals are line-buffered by default */ + if (S_ISCHR(sb.st_mode) && isatty(fileno((FILE *) fp)) == 1) + return GBM_LB; + /* Default size block buffering for the others */ + else + return GBM_BB; +} + +\end{code} diff --git a/ghc/runtime/io/getCPUTime.lc b/ghc/runtime/io/getCPUTime.lc new file mode 100644 index 0000000000..9c8230784a --- /dev/null +++ b/ghc/runtime/io/getCPUTime.lc @@ -0,0 +1,90 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getCPUTime.lc]{getCPUTime Runtime Support} + +\begin{code} + +#ifdef hpux_TARGET_OS +#define _INCLUDE_HPUX_SOURCE +#endif + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_SYS_TIMES_H +#include <sys/times.h> +#endif + +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#endif + +#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS +#include <sys/resource.h> +#endif + +#ifdef HAVE_SYS_TIMEB_H +#include <sys/timeb.h> +#endif + +#ifdef hpux_TARGET_OS +#include <sys/syscall.h> +#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b) +#define HAVE_GETRUSAGE +#endif + +/* + * Our caller wants a pointer to four StgInts, + * user seconds, user nanoseconds, system seconds, system nanoseconds. + * Yes, the timerval has unsigned components, but nanoseconds take only + * 30 bits, and our CPU usage would have to be over 68 years for the + * seconds to overflow 31 bits. + */ + +StgAddr +getCPUTime(STG_NO_ARGS) +{ + static StgInt cpu[4]; + +#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS + struct rusage t; + + getrusage(RUSAGE_SELF, &t); + cpu[0] = t.ru_utime.tv_sec; + cpu[1] = 1000 * t.ru_utime.tv_usec; + cpu[2] = t.ru_stime.tv_sec; + cpu[3] = 1000 * t.ru_stime.tv_usec; + +#else +# if defined(HAVE_TIMES) + struct tms t; +# if defined(CLK_TCK) +# define ticks CLK_TCK +# else + long ticks; + ticks = sysconf(_SC_CLK_TCK); +# endif + + times(&t); + cpu[0] = t.tms_utime / ticks; + cpu[1] = (t.tms_utime - cpu[0] * ticks) * (1000000000 / ticks); + cpu[2] = t.tms_stime / ticks; + cpu[3] = (t.tms_stime - cpu[2] * ticks) * (1000000000 / ticks); + +# else + return NULL; +# endif +#endif + return (StgAddr) cpu; +} + +\end{code} diff --git a/ghc/runtime/io/getClockTime.lc b/ghc/runtime/io/getClockTime.lc new file mode 100644 index 0000000000..2c661b8c0a --- /dev/null +++ b/ghc/runtime/io/getClockTime.lc @@ -0,0 +1,77 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getClockTime.lc]{getClockTime Runtime Support} + +\begin{code} +#define NON_POSIX_SOURCE /* gettimeofday */ + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_GETCLOCK + +# ifdef HAVE_SYS_TIMERS_H +# define POSIX_4D9 1 +# include <sys/timers.h> +# endif + +#else +# ifdef HAVE_GETTIMEOFDAY + +# ifdef HAVE_SYS_TIME_H +# include <sys/time.h> +# endif + +# else + +# ifdef HAVE_TIME_H +# include <time.h> +# endif + +# endif +#endif + +StgInt +getClockTime(sec, nsec) +StgByteArray sec; +StgByteArray nsec; +{ +#ifdef HAVE_GETCLOCK + struct timespec tp; + + if (getclock(TIMEOFDAY, &tp) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + ((unsigned long int *)sec)[0] = tp.tv_sec; + ((unsigned long int *)nsec)[0] = tp.tv_nsec; + return 0; +#else +#ifdef HAVE_GETTIMEOFDAY + struct timeval tp; + + if (gettimeofday(&tp, NULL) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + ((unsigned long int *)sec)[0] = tp.tv_sec; + ((unsigned long int *)nsec)[0] = tp.tv_usec * 1000; + return 0; +#else + time_t t; + if ((t = time(NULL)) == (time_t) -1) { + cvtErrno(); + stdErrno(); + return -1; + } + ((unsigned long int *)sec)[0] = t; + ((unsigned long int *)nsec)[0] = 0; + return 0; +#endif +#endif +} + +\end{code} diff --git a/ghc/runtime/io/getCurrentDirectory.lc b/ghc/runtime/io/getCurrentDirectory.lc new file mode 100644 index 0000000000..4da895aacc --- /dev/null +++ b/ghc/runtime/io/getCurrentDirectory.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getCurrentDirectory.lc]{getCurrentDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifndef PATH_MAX +#ifdef MAXPATHLEN +#define PATH_MAX MAXPATHLEN +#else +#define PATH_MAX 1024 +#endif +#endif + +StgAddr +getCurrentDirectory(STG_NO_ARGS) +{ + char *pwd; + int alloc; + + alloc = PATH_MAX; + if ((pwd = malloc(alloc)) == NULL) { + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "not enough virtual memory"; + return NULL; + } + while (getcwd(pwd, alloc) == NULL) { + if (errno == ERANGE) { + alloc += PATH_MAX; + if ((pwd = realloc(pwd, alloc)) == NULL) { + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "not enough virtual memory"; + return NULL; + } + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return NULL; + } + } + return (StgAddr) pwd; +} + +\end{code} diff --git a/ghc/runtime/io/getDirectoryContents.lc b/ghc/runtime/io/getDirectoryContents.lc new file mode 100644 index 0000000000..da54d7d26a --- /dev/null +++ b/ghc/runtime/io/getDirectoryContents.lc @@ -0,0 +1,126 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getDirectoryContents.lc]{getDirectoryContents Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +#ifdef HAVE_DIRENT_H +#include <dirent.h> +#endif + +#ifndef LINK_MAX +#define LINK_MAX 1024 +#endif + +/* For cleanup of partial answer on error */ + +static void +freeEntries(entries, count) + char **entries; + int count; +{ + int i; + + for (i = 0; i < count; i++) + free(entries[i]); + free(entries); +} + +/* + * Our caller expects a malloc'ed array of malloc'ed string pointers. + * To ensure consistency when mixing this with other directory + * operations, we collect the entire list in one atomic operation, + * rather than reading the directory lazily. + */ + +StgAddr +getDirectoryContents(path) +StgByteArray path; +{ + struct stat sb; + DIR *dir; + struct dirent *d; + char **entries; + int alloc, count; + + /* Check for an actual directory */ + while (stat(path, &sb) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return NULL; + } + } + if (!S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "not a directory"; + return NULL; + } + + alloc = LINK_MAX; + if ((entries = (char **) malloc(alloc * sizeof(char *))) == NULL) { + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "not enough virtual memory"; + return NULL; + } + + while ((dir = opendir(path)) == NULL) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + free(entries); + return NULL; + } + } + + count = 0; + for (;;) { + errno = 0; /* unchanged by readdir on EOF */ + while ((d = readdir(dir)) == NULL) { + if (errno == 0) { + entries[count] = NULL; + (void) closedir(dir); + return (StgAddr) entries; + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + freeEntries(entries, count); + (void) closedir(dir); + return NULL; + } + errno = 0; + } + if ((entries[count] = malloc(strlen(d->d_name))) == NULL) { + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "not enough virtual memory"; + freeEntries(entries, count); + (void) closedir(dir); + return NULL; + } + strcpy(entries[count], d->d_name); + if (++count == alloc) { + alloc += LINK_MAX; + if ((entries = (char **) realloc(entries, alloc * sizeof(char *))) == NULL) { + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "not enough virtual memory"; + freeEntries(entries, count); + (void) closedir(dir); + return NULL; + } + } + } +} + +\end{code} diff --git a/ghc/runtime/io/getLock.lc b/ghc/runtime/io/getLock.lc new file mode 100644 index 0000000000..f39014e25e --- /dev/null +++ b/ghc/runtime/io/getLock.lc @@ -0,0 +1,138 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[getLock.lc]{stdin/stout/stderr Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +#ifndef FD_SETSIZE +#define FD_SETSIZE 256 +#endif + +typedef struct { + dev_t device; + ino_t inode; + int fd; +} Lock; + +static Lock readLock[FD_SETSIZE]; +static Lock writeLock[FD_SETSIZE]; + +static int readLocks = 0; +static int writeLocks = 0; + +int +lockFile(fd, exclusive) +int fd; +int exclusive; +{ + int i; + struct stat sb; + + while (fstat(fd, &sb) < 0) { + if (errno != EINTR) { + return -1; + } + } + + /* Only lock regular files */ + if (!S_ISREG(sb.st_mode)) + return 0; + + for (i = 0; i < writeLocks; i++) + if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) { + errno = EAGAIN; + return -1; + } + + if (!exclusive) { + i = readLocks++; + readLock[i].device = sb.st_dev; + readLock[i].inode = sb.st_ino; + readLock[i].fd = fd; + return 0; + } + + for (i = 0; i < readLocks; i++) + if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) { + errno = EAGAIN; + return -1; + } + + i = writeLocks++; + writeLock[i].device = sb.st_dev; + writeLock[i].inode = sb.st_ino; + writeLock[i].fd = fd; + return 0; +} + +void +unlockFile(fd) +int fd; +{ + int i; + + for (i = 0; i < readLocks; i++) + if (readLock[i].fd == fd) { + while (++i < readLocks) + readLock[i - 1] = readLock[i]; + readLocks--; + return; + } + + for (i = 0; i < writeLocks; i++) + if (writeLock[i].fd == fd) { + while (++i < writeLocks) + writeLock[i - 1] = writeLock[i]; + writeLocks--; + return; + } +} + +StgInt +getLock(fp, exclusive) +StgAddr fp; +StgInt exclusive; +{ + if (lockFile(fileno((FILE *) fp), exclusive) < 0) { + if (errno == EBADF) + return 0; + else { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_EACCES: + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "file is locked"; + break; + } + (void) fclose((FILE *) fp); + return -1; + } + } + return 1; +} + +\end{code} diff --git a/ghc/runtime/io/ghcReadline.lc b/ghc/runtime/io/ghcReadline.lc new file mode 100644 index 0000000000..1d2133b8ec --- /dev/null +++ b/ghc/runtime/io/ghcReadline.lc @@ -0,0 +1,44 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +% Last Modified: Wed Jul 19 12:03:26 1995 +% Darren J Moffat <moffatd@dcs.gla.ac.uk> +\section[LibReadline]{GNU Readline Library Bindings} + +\begin{code} +#include "rtsdefs.h" +\end{code} + +Wrapper around the callback mechanism to allow Haskell side functions +to be callbacks for the Readline library. + +The C function $genericRlCback$ puts the cback args into global +variables and enters the Haskell world through the $haskellRlEntry$ +function. Before exiting, the Haskell function will deposit its result +in the global variable $rl_return$. + +\begin{code} + +int current_narg, rl_return, current_kc; + +char* rl_prompt_hack; + +StgStablePtr haskellRlEntry; +StgStablePtr cbackList; + + +int genericRlCback (int narg,int kc) +{ + current_narg = narg; + current_kc = kc; + + performIO(haskellRlEntry); + + return rl_return; +} + +\end{code} + + + + diff --git a/ghc/runtime/io/inputReady.lc b/ghc/runtime/io/inputReady.lc new file mode 100644 index 0000000000..fc8184e994 --- /dev/null +++ b/ghc/runtime/io/inputReady.lc @@ -0,0 +1,87 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[inputReady.lc]{hReady Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +StgInt +inputReady(fp) +StgAddr fp; +{ + int flags; + int c; + + if (feof((FILE *) fp)) + return 0; + + /* Get the original file status flags */ + while ((flags = fcntl(fileno((FILE *) fp), F_GETFL)) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + + /* If it's not already non-blocking, make it so */ + if (!(flags & O_NONBLOCK)) { + while (fcntl(fileno((FILE *) fp), F_SETFL, flags | O_NONBLOCK) < 0) { + /* still highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + } + /* Now try to get a character */ + while ((c = getc((FILE *) fp)) == EOF && errno == EINTR) + clearerr((FILE *) fp); + + /* If we made it non-blocking for this, switch it back */ + if (!(flags & O_NONBLOCK)) { + while (fcntl(fileno((FILE *) fp), F_SETFL, flags) < 0) { + /* still highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + } + + if (c == EOF) { + if (errno == EAGAIN || feof((FILE *) fp)) { + clearerr((FILE *) fp); + return 0; + } else { + cvtErrno(); + stdErrno(); + return -1; + } + } else if (ungetc(c, (FILE *) fp) == EOF) { + cvtErrno(); + stdErrno(); + return -1; + } else + return 1; +} + +\end{code} diff --git a/ghc/runtime/io/openFile.lc b/ghc/runtime/io/openFile.lc new file mode 100644 index 0000000000..73ebe2462a --- /dev/null +++ b/ghc/runtime/io/openFile.lc @@ -0,0 +1,209 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[openFile.lc]{openFile Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +StgAddr +openFile(file, how) +StgByteArray file; +StgByteArray how; +{ + FILE *fp; + int fd; + int oflags; + int exclusive; + int created = 0; + struct stat sb; + + /* + * Since we aren't supposed to succeed when we're opening for writing and + * there's another writer, we can't just do an fopen() for "w" mode. + */ + + switch (how[0]) { + case 'a': + oflags = O_WRONLY | O_NOCTTY | O_APPEND; + exclusive = 1; + break; + case 'w': + oflags = O_WRONLY | O_NOCTTY; + exclusive = 1; + break; + case 'r': + oflags = how[1] == '+' ? O_RDWR | O_NOCTTY : O_RDONLY | O_NOCTTY; + exclusive = 0; + break; + default: + fprintf(stderr, "openFile: unknown mode `%s'\n", how); + EXIT(EXIT_FAILURE); + } + + /* First try to open without creating */ + while ((fd = open(file, oflags, 0666)) < 0) { + if (errno == ENOENT) { + if (how[0] == 'r' && how[1] == '\0') { + /* For ReadMode, just bail out now */ + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "file does not exist"; + return NULL; + } + /* Now try to create it */ + while ((fd = open(file, oflags | O_CREAT | O_EXCL, 0666)) < 0) { + if (errno == EEXIST) { + /* Race detected; go back and open without creating it */ + break; + } else if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOENT: + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return NULL; + } + } + if (fd >= 0) { + created = 1; + break; + } + } else if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return NULL; + } + } + + /* Make sure that we aren't looking at a directory */ + + while (fstat(fd, &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(file); + (void) close(fd); + return NULL; + } + } + if (S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "file is a directory"; + /* We can't have created it in this case. */ + (void) close(fd); + + return NULL; + } + /* Use our own personal locking */ + + if (lockFile(fd, exclusive) < 0) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_EACCES: + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "file is locked"; + break; + } + if (created) + (void) unlink(file); + (void) close(fd); + return NULL; + } + + /* + * Write mode is supposed to truncate the file. Unfortunately, our pal + * ftruncate() is non-POSIX, so we truncate with a second open, which may fail. + */ + + if (how[0] == 'w') { + int fd2; + + oflags |= O_TRUNC; + while ((fd2 = open(file, oflags, 0666)) < 0) { + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(file); + (void) close(fd); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "enforced lock prevents truncation"; + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return NULL; + } + } + close(fd2); + } + errno = 0; /* Just in case fdopen() is lame */ + while ((fp = fdopen(fd, how)) == NULL) { + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(file); + (void) close(fd); + return NULL; + } + } + + return (StgAddr) fp; +} + +\end{code} diff --git a/ghc/runtime/io/posix.c b/ghc/runtime/io/posix.c new file mode 100644 index 0000000000..078326f33f --- /dev/null +++ b/ghc/runtime/io/posix.c @@ -0,0 +1,55 @@ +# line 7 "io/posix.lc" + +#define NULL_REG_MAP +#include "stgdefs.h" +#include "stgio.h" +#include "libposix.h" +#include "signals.h" + +int +cvtSignal(signum) +int signum; +{ + switch(signum) { + default: + return signum; + case SIGABRT: + return GHC_SIGABRT; + case SIGALRM: + return GHC_SIGALRM; + case SIGFPE: + return GHC_SIGFPE; + case SIGHUP: + return GHC_SIGHUP; + case SIGILL: + return GHC_SIGILL; + case SIGINT: + return GHC_SIGINT; + case SIGKILL: + return GHC_SIGKILL; + case SIGPIPE: + return GHC_SIGPIPE; + case SIGQUIT: + return GHC_SIGQUIT; + case SIGSEGV: + return GHC_SIGSEGV; + case SIGTERM: + return GHC_SIGTERM; + case SIGUSR1: + return GHC_SIGUSR1; + case SIGUSR2: + return GHC_SIGUSR2; + case SIGCHLD: + return GHC_SIGCHLD; + case SIGCONT: + return GHC_SIGCONT; + case SIGSTOP: + return GHC_SIGSTOP; + case SIGTSTP: + return GHC_SIGTSTP; + case SIGTTIN: + return GHC_SIGTTIN; + case SIGTTOU: + return GHC_SIGTTOU; + } +} diff --git a/ghc/runtime/io/readFile.lc b/ghc/runtime/io/readFile.lc new file mode 100644 index 0000000000..2b649e3dbd --- /dev/null +++ b/ghc/runtime/io/readFile.lc @@ -0,0 +1,102 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[readFile.lc]{hGetContents Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#define EOT 4 + +StgInt +readBlock(buf, fp, size) +StgAddr buf; +StgAddr fp; +StgInt size; +{ + int count; + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } + + while ((count = fread(buf, 1, size, (FILE *) fp)) == 0) { + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + clearerr((FILE *) fp); + } + + return count; +} + +StgInt +readLine(buf, fp, size) +StgAddr buf; +StgAddr fp; +StgInt size; +{ + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } + + while (fgets(buf, size, (FILE *) fp) == NULL) { + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + clearerr((FILE *) fp); + } + + return strlen(buf); +} + +StgInt +readChar(fp) +StgAddr fp; +{ + int c; + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } + + while ((c = getc((FILE *) fp)) == EOF) { + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + clearerr((FILE *) fp); + } + + if (isatty(fileno((FILE *) fp)) && c == EOT) + return EOF; + else + return c; +} + +\end{code} diff --git a/ghc/runtime/io/removeDirectory.lc b/ghc/runtime/io/removeDirectory.lc new file mode 100644 index 0000000000..3347fd7c09 --- /dev/null +++ b/ghc/runtime/io/removeDirectory.lc @@ -0,0 +1,57 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[removeDirectory.lc]{removeDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +StgInt +removeDirectory(path) +StgByteArray path; +{ + struct stat sb; + + /* Check for an actual directory */ + while (stat(path, &sb) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (!S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "not a directory"; + return -1; + } + while (rmdir(path) != 0) { + if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOTEMPTY: + case GHC_EEXIST: + ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; + ghc_errstr = "directory not empty"; + break; + } + return -1; + } + } + return 0; +} + +\end{code} diff --git a/ghc/runtime/io/removeFile.lc b/ghc/runtime/io/removeFile.lc new file mode 100644 index 0000000000..095b6215b5 --- /dev/null +++ b/ghc/runtime/io/removeFile.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[removeFile.lc]{removeFile Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +StgInt +removeFile(path) +StgByteArray path; +{ + struct stat sb; + + /* Check for a non-directory */ + while (stat(path, &sb) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "file is a directory"; + return -1; + } + while (unlink(path) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +\end{code} diff --git a/ghc/runtime/io/renameDirectory.lc b/ghc/runtime/io/renameDirectory.lc new file mode 100644 index 0000000000..2a41186bfe --- /dev/null +++ b/ghc/runtime/io/renameDirectory.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[renameDirectory.lc]{renameDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +StgInt +renameDirectory(opath, npath) +StgByteArray opath; +StgByteArray npath; +{ + struct stat sb; + + /* Check for an actual directory */ + while (stat(opath, &sb) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (!S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "not a directory"; + return -1; + } + while(rename(opath, npath) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} +\end{code} diff --git a/ghc/runtime/io/renameFile.lc b/ghc/runtime/io/renameFile.lc new file mode 100644 index 0000000000..2bcb9c0e04 --- /dev/null +++ b/ghc/runtime/io/renameFile.lc @@ -0,0 +1,132 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[renameFile.lc]{renameFile Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +StgInt +renameFile(opath, npath) +StgByteArray opath; +StgByteArray npath; +{ + struct stat sb; + int fd; + int created = 0; + + /* Check for a non-directory source */ + while (stat(opath, &sb) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "file is a directory"; + return -1; + } + + /* Ensure a non-directory destination */ + + /* First try to open without creating */ + while ((fd = open(npath, O_RDONLY | O_NOCTTY, 0)) < 0) { + if (errno == ENOENT) { + /* Now try to create it */ + while ((fd = open(npath, O_RDONLY | O_NOCTTY | O_CREAT | O_EXCL, 0)) < 0) { + if (errno == EEXIST) { + /* Race detected; go back and open without creating it */ + break; + } else if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOENT: + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return -1; + } + } + if (fd >= 0) { + created = 1; + break; + } + } else if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return -1; + } + } + + /* Make sure that we aren't looking at a directory */ + + while (fstat(fd, &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(npath); + (void) close(fd); + return -1; + } + } + if (S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "destination is a directory"; + /* We can't have created it in this case. */ + (void) close(fd); + return -1; + } + + while(rename(opath, npath) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + if (created) + (void) unlink(npath); + (void) close(fd); + return -1; + } + } + + close(fd); + return 0; +} +\end{code} diff --git a/ghc/runtime/io/seekFile.lc b/ghc/runtime/io/seekFile.lc new file mode 100644 index 0000000000..caff607018 --- /dev/null +++ b/ghc/runtime/io/seekFile.lc @@ -0,0 +1,135 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[seekFile.lc]{hSeek and hIsSeekable Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +StgInt +seekFile(fp, whence, size, d) +StgAddr fp; +StgInt whence; +StgInt size; +StgByteArray d; +{ + struct stat sb; + long int offset; + + /* + * We need to snatch the offset out of an MP_INT. The bits are there sans sign, + * which we pick up from our size parameter. If abs(size) is greater than 1, + * this integer is just too big. + */ + + switch (size) { + case -1: + offset = -*(StgInt *) d; + break; + case 0: + offset = 0; + break; + case 1: + offset = *(StgInt *) d; + break; + default: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "offset out of range"; + return -1; + } + + /* Try to find out the file type & size for a physical file */ + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (S_ISREG(sb.st_mode)) { + /* Verify that we are not seeking beyond end-of-file */ + int posn; + + switch (whence) { + case SEEK_SET: + posn = offset; + break; + case SEEK_CUR: + while ((posn = ftell((FILE *) fp)) == -1) { + /* the possibility seems awfully remote */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + posn += offset; + break; + case SEEK_END: + posn = sb.st_size + offset; + break; + } + if (posn > sb.st_size) { + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "seek position beyond end of file"; + return -1; + } + } else if (S_ISFIFO(sb.st_mode)) { + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't seek on a pipe"; + return -1; + } else { + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't seek on a device"; + return -1; + } + while (fseek((FILE *) fp, offset, whence) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +StgInt +seekFileP(fp) +StgAddr fp; +{ + struct stat sb; + + /* Try to find out the file type */ + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + /* Regular files are okay */ + if (S_ISREG(sb.st_mode)) { + return 1; + } + /* For now, everything else is not */ + else { + return 0; + } +} + +\end{code} + + + diff --git a/ghc/runtime/io/setBuffering.lc b/ghc/runtime/io/setBuffering.lc new file mode 100644 index 0000000000..ffccf70ca0 --- /dev/null +++ b/ghc/runtime/io/setBuffering.lc @@ -0,0 +1,123 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[setBuffering.lc]{hSetBuffering Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +#ifdef HAVE_TERMIOS_H +#include <termios.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +#define SB_NB (0) +#define SB_LB (-1) +#define SB_BB (-2) + +StgInt +setBuffering(fp, size) +StgAddr fp; +StgInt size; +{ + int flags; + int input; + struct termios tio; + + while ((flags = fcntl(fileno((FILE *) fp), F_GETFL)) < 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + flags &= O_ACCMODE; + input = flags == O_RDONLY || flags == O_RDWR; + + switch (size) { + case SB_NB: + if (setvbuf((FILE *) fp, NULL, _IONBF, 0L) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + if (input && isatty(fileno((FILE *) fp))) { + + /* + * Try to switch to CBREAK mode, or whatever they call it these days. + */ + + if (tcgetattr(fileno((FILE *) fp), &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + tio.c_lflag &= ~ICANON; + tio.c_cc[VMIN] = 1; + tio.c_cc[VTIME] = 0; + if (tcsetattr(fileno((FILE *) fp), TCSANOW, &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; + break; + case SB_LB: + if (setvbuf((FILE *) fp, NULL, _IOLBF, BUFSIZ) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + break; + case SB_BB: + + /* + * We should actually peek at the buffer size in the stat struct, if there + * is one. Something to occupy us later, when we're bored. + */ + size = BUFSIZ; + /* fall through */ + default: + if (setvbuf((FILE *) fp, NULL, _IOFBF, size) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + break; + } + if (input && isatty(fileno((FILE *) fp))) { + + /* + * Try to switch back to cooked mode. + */ + + if (tcgetattr(fileno((FILE *) fp), &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + tio.c_lflag |= ICANON; + if (tcsetattr(fileno((FILE *) fp), TCSANOW, &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +\end{code} diff --git a/ghc/runtime/io/setCurrentDirectory.lc b/ghc/runtime/io/setCurrentDirectory.lc new file mode 100644 index 0000000000..96fdf59fa9 --- /dev/null +++ b/ghc/runtime/io/setCurrentDirectory.lc @@ -0,0 +1,25 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[setCurrentDirectory.lc]{setCurrentDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +setCurrentDirectory(path) +StgByteArray path; +{ + while (chdir(path) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +\end{code} diff --git a/ghc/runtime/io/showTime.lc b/ghc/runtime/io/showTime.lc new file mode 100644 index 0000000000..79f66892cb --- /dev/null +++ b/ghc/runtime/io/showTime.lc @@ -0,0 +1,47 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[showTime.lc]{ClockTime.showsPrec Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_TIME_H +#include <time.h> +#endif + +StgAddr +showTime(size, d) +StgInt size; +StgByteArray d; +{ + time_t t; + struct tm *tm; + static char buf[32]; + + switch(size) { + default: + return (StgAddr) "ClockTime.show{LibTime}: out of range"; + case 0: + t = 0; + break; + case -1: + t = - (time_t) ((StgInt *)d)[0]; + if (t > 0) + return (StgAddr) "ClockTime.show{LibTime}: out of range"; + break; + case 1: + t = (time_t) ((StgInt *)d)[0]; + if (t < 0) + return (StgAddr) "ClockTime.show{LibTime}: out of range"; + break; + } + tm = localtime(&t); + if (tm != NULL && strftime(buf, sizeof(buf), "%a %b %d %T %Z %Y", tm) > 0) + return (StgAddr) buf; + return (StgAddr) "ClockTime.show{LibTime}: internal error"; +} + +\end{code} diff --git a/ghc/runtime/io/system.lc b/ghc/runtime/io/system.lc new file mode 100644 index 0000000000..013f111ba6 --- /dev/null +++ b/ghc/runtime/io/system.lc @@ -0,0 +1,65 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[system.lc]{system Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_WAIT_H +#include <sys/wait.h> +#endif + +#ifdef HAVE_VFORK_H +#include <vfork.h> +#endif + +#ifdef HAVE_VFORK +#define fork vfork +#endif + +StgInt +systemCmd(cmd) +StgByteArray cmd; +{ + int pid; + int wstat; + + switch(pid = fork()) { + case -1: + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + case 0: + /* the child */ + execl("/bin/sh", "sh", "-c", cmd, NULL); + _exit(127); + } + + while (waitpid(pid, &wstat, 0) < 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + + if (WIFEXITED(wstat)) + return WEXITSTATUS(wstat); + else if (WIFSIGNALED(wstat)) { + ghc_errtype = ERR_INTERRUPTED; + ghc_errstr = "system command interrupted"; + } + else { + /* This should never happen */ + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "internal error (process neither exited nor signalled)"; + } + return -1; +} + +\end{code} diff --git a/ghc/runtime/io/toClockSec.lc b/ghc/runtime/io/toClockSec.lc new file mode 100644 index 0000000000..d00da864c7 --- /dev/null +++ b/ghc/runtime/io/toClockSec.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toClockSec.lc]{toClockSec Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "timezone.h" + +StgAddr +toClockSec(year, mon, mday, hour, min, sec, tz) +StgInt year; +StgInt mon; +StgInt mday; +StgInt hour; +StgInt min; +StgInt sec; +StgInt tz; +{ + struct tm tm; + static time_t t; + + tm.tm_year = year - 1900; + tm.tm_mon = mon; + tm.tm_mday = mday; + tm.tm_hour = hour; + tm.tm_min = min; + tm.tm_sec = sec; + tm.tm_isdst = -1; + +#ifdef HAVE_MKTIME + t = mktime(&tm); +#else +#ifdef HAVE_TIMELOCAL + t = timelocal(&tm); +#else + t = (time_t) -1; +#endif +#endif + if (t == (time_t) -1) + return NULL; + else + return &t; +} + +\end{code} diff --git a/ghc/runtime/io/toLocalTime.lc b/ghc/runtime/io/toLocalTime.lc new file mode 100644 index 0000000000..50a5a104c8 --- /dev/null +++ b/ghc/runtime/io/toLocalTime.lc @@ -0,0 +1,47 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toLocalTime.lc]{toCalendarTime Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "timezone.h" + +StgAddr +toLocalTime(size, d) +StgInt size; +StgByteArray d; +{ + time_t t; + struct tm *tm; + static struct tm cache_tm; + + switch(size) { + default: + return NULL; + case 0: + t = 0; + break; + case -1: + t = - (time_t) ((StgInt *)d)[0]; + if (t > 0) + return NULL; + break; + case 1: + t = (time_t) ((StgInt *)d)[0]; + if (t < 0) + return NULL; + break; + } + tm = localtime(&t); + + if (tm == NULL) + return NULL; + + cache_tm = *tm; + return &cache_tm; +} + +\end{code} diff --git a/ghc/runtime/io/toUTCTime.lc b/ghc/runtime/io/toUTCTime.lc new file mode 100644 index 0000000000..1442993ea0 --- /dev/null +++ b/ghc/runtime/io/toUTCTime.lc @@ -0,0 +1,47 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toUTCTime.lc]{toUTCTime Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "timezone.h" + +StgAddr +toUTCTime(size, d) +StgInt size; +StgByteArray d; +{ + time_t t; + struct tm *tm; + static struct tm cache_tm; + + switch(size) { + default: + return NULL; + case 0: + t = 0; + break; + case -1: + t = - (time_t) ((StgInt *)d)[0]; + if (t > 0) + return NULL; + break; + case 1: + t = (time_t) ((StgInt *)d)[0]; + if (t < 0) + return NULL; + break; + } + tm = gmtime(&t); + + if (tm == NULL) + return NULL; + + cache_tm = *tm; + return &cache_tm; +} + +\end{code} diff --git a/ghc/runtime/io/writeFile.lc b/ghc/runtime/io/writeFile.lc new file mode 100644 index 0000000000..6981bf128c --- /dev/null +++ b/ghc/runtime/io/writeFile.lc @@ -0,0 +1,38 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[writeFile.lc]{hPutStr Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +writeFile(buf, fp, bytes) +StgAddr buf; +StgAddr fp; +StgInt bytes; +{ + int count; + char *p = (char *) buf; + + if (bytes == 0) + return 0; + + /* Disallow short writes */ + while ((count = fwrite(p, 1, bytes, (FILE *) fp)) < bytes) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + bytes -= count; + p += count; + clearerr((FILE *) fp); + } + + return 0; +} + +\end{code} |