diff options
Diffstat (limited to 'ghc/lib/std/cbits')
38 files changed, 3614 insertions, 0 deletions
diff --git a/ghc/lib/std/cbits/Makefile b/ghc/lib/std/cbits/Makefile new file mode 100644 index 0000000000..b330b627d5 --- /dev/null +++ b/ghc/lib/std/cbits/Makefile @@ -0,0 +1,30 @@ +# $Id: Makefile,v 1.1 1998/02/02 17:34:22 simonm Exp $ + +TOP = ../../.. +include $(TOP)/mk/boilerplate.mk +override WAYS= + +LIBRARY=libHS_cbits.a +INSTALL_LIBS+=$(LIBRARY) + +SRCS= $(wildcard *.lc) + +C_SRCS = $(SRCS:.lc=.c) +C_OBJS = $(C_SRCS:.c=.o) +LIBOBJS = $(C_OBJS) +SRC_CC_OPTS = -O -I$(GHC_INCLUDE_DIR) + +# +# Compile the files using the Haskell compiler (ghc really). +# +CC=$(HC) + +# +# Remove the intermediate .c files +# (the .o's will be removed automatically by default mk setup) +# +CLEAN_FILES += $(C_SRCS) + +SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) + +include $(TOP)/mk/target.mk diff --git a/ghc/lib/std/cbits/closeFile.lc b/ghc/lib/std/cbits/closeFile.lc new file mode 100644 index 0000000000..9f4c80eb8d --- /dev/null +++ b/ghc/lib/std/cbits/closeFile.lc @@ -0,0 +1,35 @@ +% +% (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) +StgForeignObj fp; +{ + int rc; + + if (unlockFile(fileno((FILE *) fp))) { + /* If it has been unlocked, don't bother fclose()ing */ + return 0; + } + + while ((rc = fclose((FILE *) fp)) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return rc; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/lib/std/cbits/createDirectory.lc b/ghc/lib/std/cbits/createDirectory.lc new file mode 100644 index 0000000000..759e99c998 --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/errno.lc b/ghc/lib/std/cbits/errno.lc new file mode 100644 index 0000000000..0eaa9d1ac9 --- /dev/null +++ b/ghc/lib/std/cbits/errno.lc @@ -0,0 +1,934 @@ +% +% (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 +#ifndef aix_TARGET_OS +/* AIX returns EEXIST where 4.3BSD used ENOTEMPTY. + * there is an ENOTEMPTY defined as the same as EEXIST, and + * therefore it won't work properly on a case statement. + * another option is to define _ALL_SOURCE for aix, which + * gives a different number for ENOTEMPTY. + * I haven't tried that. -- andre. + */ +#ifdef ENOTEMPTY + case ENOTEMPTY: + ghc_errno = GHC_ENOTEMPTY; + break; +#endif +#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/lib/std/cbits/fileEOF.lc b/ghc/lib/std/cbits/fileEOF.lc new file mode 100644 index 0000000000..cdd3eb20cf --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj fp; +{ + if (fileLookAhead(fp) != EOF) + return 0; + else if (ghc_errtype == ERR_EOF) + return 1; + else + return -1; +} + +\end{code} diff --git a/ghc/lib/std/cbits/fileGetc.lc b/ghc/lib/std/cbits/fileGetc.lc new file mode 100644 index 0000000000..131c956364 --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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/lib/std/cbits/fileLookAhead.lc b/ghc/lib/std/cbits/fileLookAhead.lc new file mode 100644 index 0000000000..91a172251d --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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/lib/std/cbits/filePosn.lc b/ghc/lib/std/cbits/filePosn.lc new file mode 100644 index 0000000000..7a0d7907b8 --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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) +StgForeignObj 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/lib/std/cbits/filePutc.lc b/ghc/lib/std/cbits/filePutc.lc new file mode 100644 index 0000000000..4e6b85bb04 --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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/lib/std/cbits/fileSize.lc b/ghc/lib/std/cbits/fileSize.lc new file mode 100644 index 0000000000..34348feedf --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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/lib/std/cbits/floatExtreme.h b/ghc/lib/std/cbits/floatExtreme.h new file mode 100644 index 0000000000..e073985706 --- /dev/null +++ b/ghc/lib/std/cbits/floatExtreme.h @@ -0,0 +1,13 @@ +#ifndef FLOATEXTREME_H +#define FLOATEXTREME_H + +StgInt isDoubleNaN PROTO((StgDouble)); +StgInt isDoubleInfinite PROTO((StgDouble)); +StgInt isDoubleDenormalized PROTO((StgDouble)); +StgInt isDoubleNegativeZero PROTO((StgDouble)); +StgInt isFloatNaN PROTO((StgFloat)); +StgInt isFloatInfinite PROTO((StgFloat)); +StgInt isFloatDenormalized PROTO((StgFloat)); +StgInt isFloatNegativeZero PROTO((StgFloat)); + +#endif /* FLOATEXTREME_H */ diff --git a/ghc/lib/std/cbits/floatExtreme.lc b/ghc/lib/std/cbits/floatExtreme.lc new file mode 100644 index 0000000000..3dbecdeee5 --- /dev/null +++ b/ghc/lib/std/cbits/floatExtreme.lc @@ -0,0 +1,174 @@ +% +% +% + +Stubs to check for extremities of (IEEE) floats, +the tests have been (artfully) lifted from the hbc-0.9999.3 (lib/fltcode.c) +source. + +ToDo: + - avoid hard-wiring the fact that on an + Alpha we repr. a StgFloat as a double. + (introduce int equivalent of {ASSIGN,PK}_FLT? ) + +\begin{code} + +#include "rtsdefs.h" +#include "ieee-flpt.h" +#include "floatExtreme.h" + +#ifdef BIGENDIAN +#define L 1 +#define H 0 +#else +#define L 0 +#define H 1 +#endif + +#ifdef IEEE_FLOATING_POINT + +StgInt +isDoubleNaN(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int hx,lx; + int r; + + u.d = d; + hx = u.i[H]; + lx = u.i[L]; + hx &= 0x7fffffff; + hx |= (unsigned int)(lx|(-lx))>>31; + hx = 0x7ff00000 - hx; + r = (int)((unsigned int)(hx))>>31; + return (r); +} + +StgInt +isDoubleInfinite(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int hx,lx; + + u.d = d; + hx = u.i[H]; + lx = u.i[L]; + hx &= 0x7fffffff; + hx ^= 0x7ff00000; + hx |= lx; + return (hx == 0); +} + +StgInt +isDoubleDenormalized(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int high, iexp; + + u.d = d; + high = u.i[H]; + iexp = high & (0x7ff << 20); + return (iexp == 0); +} + +StgInt +isDoubleNegativeZero(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int high, iexp; + + u.d = d; + return (u.i[H] == 0x80000000 && u.i[L] == 0); +} + +/* Same tests, this time for StgFloats. */ + +StgInt +isFloatNaN(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleNaN(f)); +#else + union { StgFloat f; int i; } u; + int r; + u.f = f; + + u.i &= 0x7fffffff; + u.i = 0x7f800000 - u.i; + r = (int)(((unsigned int)(u.i))>>31); + return (r); +#endif +} + +StgInt +isFloatInfinite(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleInfinite(f)); +#else + int ix; + union { StgFloat f; int i; } u; + u.f = f; + + u.i &= 0x7fffffff; + u.i ^= 0x7f800000; + return (u.i == 0); +#endif +} + +StgInt +isFloatDenormalized(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleDenormalized(f)); +#else + int iexp; + union { StgFloat f; int i; } u; + u.f = f; + + iexp = u.i & (0xff << 23); + return (iexp == 0); +#endif +} + +StgInt +isFloatNegativeZero(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleNegativeZero(f)); +#else + union { StgFloat f; int i; } u; + u.f = f; + + return (u.i == (int)0x80000000); +#endif +} + + +#else + +StgInt isDoubleNaN(d) StgDouble d; { return 0; } +StgInt isDoubleInfinite(d) StgDouble d; { return 0; } +StgInt isDoubleDenormalized(d) StgDouble d; { return 0; } +StgInt isDoubleNegativeZero(d) StgDouble d; { return 0; } +StgInt isFloatNaN(f) StgFloat f; { return 0; } +StgInt isFloatInfinite(f) StgFloat f; { return 0; } +StgInt isFloatDenormalized(f) StgFloat f; { return 0; } +StgInt isFloatNegativeZero(f) StgFloat f; { return 0; } + +#endif + + +\end{code} diff --git a/ghc/lib/std/cbits/flushFile.lc b/ghc/lib/std/cbits/flushFile.lc new file mode 100644 index 0000000000..6cfd484e74 --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj fp; +{ + int rc; + + while ((rc = fflush((FILE *) fp)) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return rc; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/lib/std/cbits/freeFile.lc b/ghc/lib/std/cbits/freeFile.lc new file mode 100644 index 0000000000..1ac3d52661 --- /dev/null +++ b/ghc/lib/std/cbits/freeFile.lc @@ -0,0 +1,52 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1997 +% +\subsection[freeFile.lc]{Giving up files} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +/* sigh, the FILEs attached to the standard descriptors are + handled differently. We don't want them freed via the + ForeignObj finaliser, as we probably want to use these + before we *really* shut down (dumping stats etc.) +*/ +void freeStdFile(fp) +StgForeignObj fp; +{ return; } + +void freeFile(fp) +StgForeignObj fp; +{ + int rc; + + if ( fp == NULL || (rc = unlockFile(fileno((FILE *)fp))) ) { + /* If the file handle has been explicitly closed + * (via closeFile()) or freed, we will have given + * up our process lock, so we silently return here. + */ + return; + } + + /* + * The finaliser for the FILEs embedded in Handles. The RTS + * assumes that the finaliser runs without problems, so all + * we can do here is fclose(), and hope nothing went wrong. + * + * Assume fclose() flushes output stream. + */ + + rc = fclose((FILE *)fp); + /* Error or no error, we don't care.. */ + + /* + if ( rc == EOF ) { + fprintf(stderr. "Warning: file close ran into trouble\n"); + } + */ + + return; +} +\end{code} diff --git a/ghc/lib/std/cbits/getBufferMode.lc b/ghc/lib/std/cbits/getBufferMode.lc new file mode 100644 index 0000000000..cb0b9840d2 --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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/lib/std/cbits/getCPUTime.lc b/ghc/lib/std/cbits/getCPUTime.lc new file mode 100644 index 0000000000..d3d7b2a489 --- /dev/null +++ b/ghc/lib/std/cbits/getCPUTime.lc @@ -0,0 +1,107 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getCPUTime.lc]{getCPUTime Runtime Support} + +\begin{code} + +#ifndef _AIX +#define NON_POSIX_SOURCE /*needed for solaris2 only?*/ +#endif + +/* how is this to work given we have not read platform.h yet? */ +#ifdef hpux_TARGET_OS +#define _INCLUDE_HPUX_SOURCE +#endif + +#include "rtsdefs.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 + +StgInt +clockTicks () +{ + return ( +#if defined(CLK_TCK) + CLK_TCK +#else + sysconf(_SC_CLK_TCK) +#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. + */ + +StgByteArray +getCPUTime(StgByteArray cpuStruct) +{ + StgInt *cpu=(StgInt *)cpuStruct; + +#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 (StgByteArray) cpuStruct; +} + +\end{code} + diff --git a/ghc/lib/std/cbits/getClockTime.lc b/ghc/lib/std/cbits/getClockTime.lc new file mode 100644 index 0000000000..b6f42e6c28 --- /dev/null +++ b/ghc/lib/std/cbits/getClockTime.lc @@ -0,0 +1,77 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getClockTime.lc]{getClockTime Runtime Support} + +\begin{code} + +#ifndef _AIX +#define NON_POSIX_SOURCE /* gettimeofday */ +#endif + +#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(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/lib/std/cbits/getCurrentDirectory.lc b/ghc/lib/std/cbits/getCurrentDirectory.lc new file mode 100644 index 0000000000..4da895aacc --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/getDirectoryContents.lc b/ghc/lib/std/cbits/getDirectoryContents.lc new file mode 100644 index 0000000000..025aae9751 --- /dev/null +++ b/ghc/lib/std/cbits/getDirectoryContents.lc @@ -0,0 +1,124 @@ +% +% (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(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/lib/std/cbits/getLock.lc b/ghc/lib/std/cbits/getLock.lc new file mode 100644 index 0000000000..1ed0dbf7ee --- /dev/null +++ b/ghc/lib/std/cbits/getLock.lc @@ -0,0 +1,140 @@ +% +% (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; +} + +int +unlockFile(fd) +int fd; +{ + int i, rc; + + for (i = 0; i < readLocks; i++) + if (readLock[i].fd == fd) { + while (++i < readLocks) + readLock[i - 1] = readLock[i]; + readLocks--; + return 0; + } + + for (i = 0; i < writeLocks; i++) + if (writeLock[i].fd == fd) { + while (++i < writeLocks) + writeLock[i - 1] = writeLock[i]; + writeLocks--; + return 0; + } + /* Signal that we did not find an entry */ + return 1; +} + +StgInt +getLock(fp, exclusive) +StgForeignObj 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/lib/std/cbits/inputReady.lc b/ghc/lib/std/cbits/inputReady.lc new file mode 100644 index 0000000000..8baa582971 --- /dev/null +++ b/ghc/lib/std/cbits/inputReady.lc @@ -0,0 +1,126 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[inputReady.lc]{hReady Runtime Support} + +\begin{code} + +/* select and supporting types is not */ +#ifndef _AIX +#define NON_POSIX_SOURCE +#endif + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef _AIX +/* this is included from sys/types.h only if _BSD is defined. */ +/* Since it is not, I include it here. - andre */ +#include <sys/select.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#endif + +StgInt +inputReady(fp, nsecs) +StgForeignObj fp; +StgInt nsecs; +{ + int flags, c, fd, maxfd, ready; + fd_set rfd; + struct timeval tv; + + if (feof((FILE *) fp)) + return 0; + + fd = fileno((FILE *)fp); + + /* Get the original file status flags */ + while ((flags = fcntl(fd, 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(fd, F_SETFL, flags | O_NONBLOCK) < 0) { + /* still highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + } + /* Now try to get a character */ + FD_ZERO(&rfd); + FD_SET(fd, &rfd); + /* select() will consider the descriptor set in the range of 0 to (maxfd-1) */ + maxfd = fd + 1; + tv.tv_usec = 0; + tv.tv_sec = nsecs; + while ((ready = select(maxfd, &rfd, NULL, NULL, &tv)) < 0 ) { + if (errno != EINTR ) { + cvtErrno(); + stdErrno(); + ready = -1; + break; + } + } + /* + 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(fd, F_SETFL, flags) < 0) { + /* still highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + } + /* 1 => Input ready, 0 => time expired (-1 error) */ + return (ready); + + /* + 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/lib/std/cbits/openFile.lc b/ghc/lib/std/cbits/openFile.lc new file mode 100644 index 0000000000..4b92aca8b5 --- /dev/null +++ b/ghc/lib/std/cbits/openFile.lc @@ -0,0 +1,217 @@ +% +% (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; + } else { + /* If it is a dangling symlink, break off now, too. */ + struct stat st; + if ( lstat(file,&st) == 0) { + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "dangling symlink"; + 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/lib/std/cbits/readFile.lc b/ghc/lib/std/cbits/readFile.lc new file mode 100644 index 0000000000..0cc9c2c7b9 --- /dev/null +++ b/ghc/lib/std/cbits/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; +StgForeignObj 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; +StgForeignObj 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) +StgForeignObj 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/lib/std/cbits/removeDirectory.lc b/ghc/lib/std/cbits/removeDirectory.lc new file mode 100644 index 0000000000..3347fd7c09 --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/removeFile.lc b/ghc/lib/std/cbits/removeFile.lc new file mode 100644 index 0000000000..095b6215b5 --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/renameDirectory.lc b/ghc/lib/std/cbits/renameDirectory.lc new file mode 100644 index 0000000000..2a41186bfe --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/renameFile.lc b/ghc/lib/std/cbits/renameFile.lc new file mode 100644 index 0000000000..2bcb9c0e04 --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/seekFile.lc b/ghc/lib/std/cbits/seekFile.lc new file mode 100644 index 0000000000..48c0cf7d3b --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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) +StgForeignObj 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/lib/std/cbits/setBuffering.lc b/ghc/lib/std/cbits/setBuffering.lc new file mode 100644 index 0000000000..0169b50ce2 --- /dev/null +++ b/ghc/lib/std/cbits/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) +StgForeignObj 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/lib/std/cbits/setCurrentDirectory.lc b/ghc/lib/std/cbits/setCurrentDirectory.lc new file mode 100644 index 0000000000..96fdf59fa9 --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/showTime.lc b/ghc/lib/std/cbits/showTime.lc new file mode 100644 index 0000000000..08adcd50f4 --- /dev/null +++ b/ghc/lib/std/cbits/showTime.lc @@ -0,0 +1,51 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[showTime.lc]{ClockTime.showsPrec Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +#endif + +StgAddr +showTime(I_ size, StgByteArray d, StgByteArray buf) +{ + time_t t; + struct tm *tm; + + switch(size) { + default: + return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range"); + case 0: + t = 0; + break; + case -1: + t = - (time_t) ((StgInt *)d)[0]; + if (t > 0) + return + (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range"); + break; + case 1: + t = (time_t) ((StgInt *)d)[0]; + if (t < 0) + return (StgAddr) strcpy(buf, "ClockTime.show{LibTime}: out of range"); + break; + } + tm = localtime(&t); + if (tm != NULL && strftime(buf, 32 /*Magic number*/, "%a %b %d %T %Z %Y", tm) > 0) + return (StgAddr)buf; + return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: internal error"); +} +\end{code} diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h new file mode 100644 index 0000000000..2c5eab247d --- /dev/null +++ b/ghc/lib/std/cbits/stgio.h @@ -0,0 +1,133 @@ +#ifndef STGIO_H +#define STGIO_H + +/* Decls for routines in ghc/lib/cbits/ only used there. + * This file is used when compiling the Haskell library + * that _ccalls_ those routines; and when compiling those + * routines (to check consistency). + */ + +/* closeFile.lc */ +StgInt closeFile PROTO((StgForeignObj)); + +/* createDirectory.lc */ +StgInt createDirectory PROTO((StgByteArray)); + +/* env.lc */ +char * strDup PROTO((const char *)); +int setenviron PROTO((char **)); +int copyenv (STG_NO_ARGS); +int _setenv PROTO((char *)); +int delenv PROTO((char *)); + +/* errno.lc */ +extern int ghc_errno; +extern int ghc_errtype; +void cvtErrno(STG_NO_ARGS); +void stdErrno(STG_NO_ARGS); + +/* execvpe.lc */ +int execvpe PROTO((char *, char **, char **)); + +/* fileEOF.lc */ +StgInt fileEOF PROTO((StgForeignObj)); +/* fileGetc.lc */ +StgInt fileGetc PROTO((StgForeignObj)); + +/* fileLookAhead.lc */ +StgInt fileLookAhead PROTO((StgForeignObj)); + +/* filePosn.lc */ +StgInt getFilePosn PROTO((StgForeignObj)); +StgInt setFilePosn PROTO((StgForeignObj, StgInt)); + +/* filePutc.lc */ +StgInt filePutc PROTO((StgForeignObj, StgInt)); + +/* fileSize.lc */ +StgInt fileSize PROTO((StgForeignObj, StgByteArray)); + +/* flushFile.lc */ +StgInt flushFile PROTO((StgForeignObj)); + +/* freeFile.lc */ +void freeStdFile PROTO((StgForeignObj)); +void freeFile PROTO((StgForeignObj)); + +/* getBufferMode.lc */ +StgInt getBufferMode PROTO((StgForeignObj)); + +/* getClockTime.lc */ +StgInt getClockTime PROTO((StgByteArray, StgByteArray)); +StgAddr showTime PROTO((I_, StgByteArray, StgByteArray)); +StgAddr toClockSec PROTO((I_, I_, I_, I_, I_, I_, I_, StgByteArray)); +StgAddr toLocalTime PROTO((I_, StgByteArray, StgByteArray)); +StgAddr toUTCTime PROTO((I_, StgByteArray, StgByteArray)); + +/* getCPUTime.lc */ +StgByteArray getCPUTime PROTO((StgByteArray)); +StgInt clockTicks(); + +/* getCurrentDirectory.lc */ +StgAddr getCurrentDirectory(STG_NO_ARGS); + +/* getDirectoryContents.lc */ +StgAddr getDirectoryContents PROTO((StgByteArray)); + +/* getLock.lc */ +int lockFile PROTO((int, int)); +int unlockFile PROTO((int)); +StgInt getLock PROTO((StgForeignObj, StgInt)); + +/* inputReady.lc */ +StgInt inputReady PROTO((StgForeignObj,StgInt)); + +/* openFile.lc */ +StgAddr openFile PROTO((StgByteArray, StgByteArray)); + +/* readFile.lc */ +StgInt readBlock PROTO((StgAddr, StgForeignObj, StgInt)); +StgInt readLine PROTO((StgAddr, StgForeignObj, StgInt)); +StgInt readChar PROTO((StgForeignObj)); + +/* removeDirectory.lc */ +StgInt removeDirectory PROTO((StgByteArray)); + +/* removeFile.lc */ +StgInt removeFile PROTO((StgByteArray)); + +/* renameDirectory.lc */ +StgInt renameDirectory PROTO((StgByteArray, StgByteArray)); + +/* renameFile.lc */ +StgInt renameFile PROTO((StgByteArray, StgByteArray)); + +/* seekFile.lc */ +StgInt seekFile PROTO((StgForeignObj, StgInt, StgInt, StgByteArray)); +StgInt seekFileP PROTO((StgForeignObj)); + +/* setBuffering.lc */ +StgInt setBuffering PROTO((StgForeignObj, StgInt)); + +/* setCurrentDirectory.lc */ +StgInt setCurrentDirectory PROTO((StgByteArray)); + +/* showTime.lc */ +StgAddr showTime PROTO((StgInt, StgByteArray, StgByteArray)); + +/* system.lc */ +StgInt systemCmd PROTO((StgByteArray)); + +/* toLocalTime.lc */ +StgAddr toLocalTime PROTO((StgInt, StgByteArray, StgByteArray)); + +/* toUTCTime.lc */ +StgAddr toUTCTime PROTO((StgInt, StgByteArray, StgByteArray)); + +/* toClockSec.lc */ +StgAddr toClockSec PROTO((StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgByteArray)); + +/* writeFile.lc */ +StgInt writeFile PROTO((StgAddr, StgForeignObj, StgInt)); + +#endif /* ! STGIO_H */ diff --git a/ghc/lib/std/cbits/system.lc b/ghc/lib/std/cbits/system.lc new file mode 100644 index 0000000000..013f111ba6 --- /dev/null +++ b/ghc/lib/std/cbits/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/lib/std/cbits/timezone.h b/ghc/lib/std/cbits/timezone.h new file mode 100644 index 0000000000..46b907f269 --- /dev/null +++ b/ghc/lib/std/cbits/timezone.h @@ -0,0 +1,47 @@ +#ifndef TIMEZONE_H +#define TIMEZONE_H + +#define _OSF_SOURCE + +#if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +#endif + +#if HAVE_TM_ZONE +#define ZONE(x) (((struct tm *)x)->tm_zone) +#define SETZONE(x,z) (((struct tm *)x)->tm_zone = z) +#define GMTOFF(x) (((struct tm *)x)->tm_gmtoff) +#else /* ! HAVE_TM_ZONE */ +# if HAVE_TZNAME || cygwin32_TARGET_OS +#if cygwin32_TARGET_OS +extern char *tzname; +#else +extern char *tzname[2]; +#endif +# define ZONE(x) (((struct tm *)x)->tm_isdst ? tzname[1] : tzname[0]) +# define SETZONE(x,z) +# else /* ! HAVE_TZNAME */ +/* We're in trouble. If you should end up here, please report this as a bug. */ +# error Dont know how to get at timezone name on your OS. +# endif /* ! HAVE_TZNAME */ +/* Get the offset in secs from UTC, if (struct tm) doesn't supply it. */ + +extern TYPE_TIMEZONE timezone; + +# if HAVE_ALTZONE +extern time_t altzone; +# define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone) +# else /* ! HAVE_ALTZONE */ +/* Assume that DST offset is 1 hour ... */ +# define GMTOFF(x) (((struct tm *)x)->tm_isdst ? (timezone - 3600) : timezone) +# endif /* ! HAVE_ALTZONE */ +#endif /* ! HAVE_TM_ZONE */ + +#endif /* TIMEZONE_H */ diff --git a/ghc/lib/std/cbits/toClockSec.lc b/ghc/lib/std/cbits/toClockSec.lc new file mode 100644 index 0000000000..3107ae37e3 --- /dev/null +++ b/ghc/lib/std/cbits/toClockSec.lc @@ -0,0 +1,41 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toClockSec.lc]{toClockSec Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "timezone.h" +#include "stgio.h" + +StgAddr +toClockSec(I_ year, I_ mon, I_ mday, I_ hour, I_ min, I_ sec, I_ isdst, StgByteArray res) +{ + struct tm tm; + 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 = isdst; + +#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; + + *(time_t *)res = t; + return res; +} +\end{code} diff --git a/ghc/lib/std/cbits/toLocalTime.lc b/ghc/lib/std/cbits/toLocalTime.lc new file mode 100644 index 0000000000..11a1e30d9b --- /dev/null +++ b/ghc/lib/std/cbits/toLocalTime.lc @@ -0,0 +1,67 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toLocalTime.lc]{toCalendarTime Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "timezone.h" +#include "stgio.h" + +StgAddr +toLocalTime(I_ size, StgByteArray d, StgByteArray res) +{ + struct tm *tm,*tmp=(struct tm *)res; + time_t t; + + 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; + + /* + localtime() may return a ptr to statically allocated storage, + so to make toLocalTime reentrant, we manually copy + the structure into the (struct tm *) passed in. + */ + tmp->tm_sec = tm->tm_sec; + tmp->tm_min = tm->tm_min; + tmp->tm_hour = tm->tm_hour; + tmp->tm_mday = tm->tm_mday; + tmp->tm_mon = tm->tm_mon; + tmp->tm_year = tm->tm_year; + tmp->tm_wday = tm->tm_wday; + tmp->tm_yday = tm->tm_yday; + tmp->tm_isdst = tm->tm_isdst; + /* + If you don't have tm_zone in (struct tm), but + you get at it via the shared tmzone[], you'll + lose. Same goes for the tm_gmtoff field. + + */ +#if HAVE_TM_ZONE + strcpy(tmp->tm_zone,tm->tm_zone); + tmp->tm_gmtoff = tm->tm_gmtoff; +#endif + + return (StgAddr)res; +} +\end{code} diff --git a/ghc/lib/std/cbits/toUTCTime.lc b/ghc/lib/std/cbits/toUTCTime.lc new file mode 100644 index 0000000000..86f449e286 --- /dev/null +++ b/ghc/lib/std/cbits/toUTCTime.lc @@ -0,0 +1,72 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toUTCTime.lc]{toUTCTime Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "timezone.h" +#include "stgio.h" + +#ifdef cygwin32_TARGET_OS +extern char *_tzname; +char *tzname; +#endif + +StgAddr +toUTCTime(I_ size, StgByteArray d, StgByteArray res) +{ + time_t t; + struct tm *tm,*tmp=(struct tm *)res; + + 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; + + /* + gmtime() may return a ptr to statically allocated storage, + so to make toUTCTime reentrant, we manually copy + the structure into the (struct tm *) passed in. + */ + tmp->tm_sec = tm->tm_sec; + tmp->tm_min = tm->tm_min; + tmp->tm_hour = tm->tm_hour; + tmp->tm_mday = tm->tm_mday; + tmp->tm_mon = tm->tm_mon; + tmp->tm_year = tm->tm_year; + tmp->tm_wday = tm->tm_wday; + tmp->tm_yday = tm->tm_yday; + tmp->tm_isdst = tm->tm_isdst; + /* + If you don't have tm_zone in (struct tm), but + you get at it via the shared tmzone[], you'll + lose. Same goes for the tm_gmtoff field. + + */ +#if HAVE_TM_ZONE + strcpy(tmp->tm_zone,tm->tm_zone); + tmp->tm_gmtoff = tm->tm_gmtoff; +#endif + + return (StgAddr)res; +} +\end{code} diff --git a/ghc/lib/std/cbits/writeFile.lc b/ghc/lib/std/cbits/writeFile.lc new file mode 100644 index 0000000000..71c7b0df17 --- /dev/null +++ b/ghc/lib/std/cbits/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; +StgForeignObj 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} |