/* This file is part of the Q programming system. The Q programming system is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. The Q programming system is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ #if defined (HAVE_CONFIG_H) # include "config.h" #endif /* system headers */ /* get the SUSV2 stuff (PTHREAD_MUTEX_RECURSIVE etc.) */ #ifndef _XOPEN_SOURCE #define _XOPEN_SOURCE 500 #endif /* get some BSDish stuff from the GNU library (Linux etc.) */ #define _BSD_SOURCE /* get IPv6 stuff from Solaris */ #define __EXTENSIONS__ #include #include #include #include #ifdef HAVE_ERRNO_H #include #else # ifndef errno extern int errno; # endif #endif #include /* check for standard C headers */ #if STDC_HEADERS # include # include #else # ifndef HAVE_STRCHR # define strchr index # define strrchr rindex # endif char *strchr (), *strrchr (); #endif #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #if TIME_WITH_SYS_TIME # include # include #else # if HAVE_SYS_TIME_H # include # else # include # endif #endif #include #if HAVE_SYS_WAIT_H # include #endif #ifndef WEXITSTATUS # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) #endif #ifndef WIFEXITED # define WIFEXITED(stat_val) (((stat_val) & 255) == 0) #endif #if HAVE_DIRENT_H # include # define NAMLEN(dirent) strlen((dirent)->d_name) #else # define dirent direct # define NAMLEN(dirent) (dirent)->d_namlen # if HAVE_SYS_NDIR_H # include # endif # if HAVE_SYS_DIR_H # include # endif # if HAVE_NDIR_H # include # endif #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_PWD_H #include #endif #ifdef HAVE_GRP_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_SYS_SELECT_H #include #endif #ifdef HAVE_TERMIOS_H #include #endif #ifdef HAVE_PTY_H #include #else #ifdef HAVE_UTIL_H #include #endif #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_STROPTS_H #include #endif #ifdef HAVE_SYS_SOCKET_H #include #ifdef HAVE_SYS_UN_H #include #endif #include #ifdef HAVE_ARPA_INET_H #include #endif #endif #ifdef HAVE_NETDB_H #include #endif #ifdef HAVE_UTIME_H #include #endif #ifdef HAVE_SYS_UTSNAME_H #include #endif #ifdef HAVE_SYS_TIMES_H #include #endif #ifdef USE_THREADS #ifdef HAVE_SCHED_H #include #endif #include #include #endif #if defined(HAVE_SYS_SOCKET_H) || defined(WIN32) #define HAVE_BSD_SOCKETS 1 #endif #ifdef WIN32 #include #include #include #include #include #define HAVE_STRDUP 1 #define HAVE_MEMCPY 1 #define HAVE_MEMCMP 1 #define HAVE_MEMMOVE 1 #define HAVE_MEMSET 1 #define HAVE_DUP 1 #define HAVE_DUP2 1 #define HAVE_PIPE 1 #define HAVE_FSTAT 1 #define HAVE_ACCESS 1 #define HAVE_CHMOD 1 #define HAVE_UTIME_H 1 #define HAVE_READDIR 1 #define HAVE_REWINDDIR 1 /* this one only works on sockets in Windows */ #define HAVE_SELECT 1 #define HAVE_SOCKET 1 #define HAVE_SHUTDOWN 1 #define HAVE_CLOSESOCKET 1 #define HAVE_BIND 1 #define HAVE_LISTEN 1 #define HAVE_ACCEPT 1 #define HAVE_CONNECT 1 #define HAVE_GETSOCKNAME 1 #define HAVE_GETPEERNAME 1 #define HAVE_GETSOCKOPT 1 #define HAVE_SETSOCKOPT 1 #define HAVE_RECV 1 #define HAVE_SEND 1 #define HAVE_RECVFROM 1 #define HAVE_SENDTO 1 #define HAVE_GETHOSTNAME 1 #define HAVE_GETHOSTBYNAME 1 #define HAVE_GETHOSTBYADDR 1 #define HAVE_GETPROTOBYNAME 1 #define HAVE_GETPROTOBYNUMBER 1 #define HAVE_GETSERVBYNAME 1 #define HAVE_GETSERVBYPORT 1 #define MSG_EOR (-1) #define MSG_WAITALL (-1) #define HAVE_IN_PORT_T 1 #define HAVE_IN_ADDR_T 1 #define HAVE_UINT16_T 1 #define uint16_t u_short #define HAVE_DECL_TZNAME 1 #define HAVE_DECL_DAYLIGHT 1 #endif /* make sure that gmp.h is included prior to libq.h */ #include #include /* work around a bug in some gmp versions */ #define my_mpz_fits_slong_p(z) (mpz_size(z) == 0 || mpz_fits_slong_p(z)) #define my_mpz_fits_ulong_p(z) (mpz_size(z) == 0 || mpz_fits_ulong_p(z)) #define my_mpz_fits_uint_p(z) (mpz_size(z) == 0 || mpz_fits_uint_p(z)) #include "glob.h" #include "fnmatch.h" #include "regex.h" #ifdef DMALLOC #include #endif MODULE(clib) #ifndef HAVE_STRDUP static char *strdup(char *s) { char *t; return ((t=malloc(strlen(s)+1))?strcpy(t, s):NULL); } #endif #ifndef HAVE_MEMCPY #if __GNUC__ > 1 #define memcpy(TO,FROM,COUNT) __builtin_memcpy(TO,FROM,COUNT) #else static void *memcpy (to, from, count) char *to; char *from; int count; { register char *f = from; register char *t = to; register int i = count; while (i-- > 0) *t++ = *f++; return (void*)to; } #endif #endif #ifndef HAVE_MEMMOVE #if __GNUC__ > 1 #define memmove(TO,FROM,COUNT) __builtin_memmove(TO,FROM,COUNT) #else static void *memmove (char *to, char *from, int count) { register char *f = from; register char *t = to; register int i = count; if (from > to) { while (i-- > 0) *t++ = *f++; } else if (from < to) { from += count; to += count; while (i-- > 0) *--t = *--f; } return (void*)to; } #endif #endif #ifndef HAVE_MEMSET #if __GNUC__ > 1 #define memset(TO,C,COUNT) __builtin_memset(TO,C,COUNT) #else static void *memset (char *to, int c, int count) { register char f = (char)c; register char *t = to; register int i = count; while (i-- > 0) *t++ = f; return (void*)to; } #endif #endif #ifndef HAVE_MEMCMP #if __GNUC__ > 1 #define memcmp(S1,S2,COUNT) __builtin_memcmp(S1,S2,COUNT) #else static int memcmp (char *s1, char *s2, int count) { register char *t1 = s1; register char *t2 = s2; register int i = count; register int c; while (i-- > 0) if ((c = *t1++ - *t2++) != 0) return c; return 0; } #endif #endif #define BUFSZ 1024 /* GMP convenience stuff */ #define BYTES_PER_LIMB sizeof(mp_limb_t) static void* my_mpz_realloc(m, new_size) mpz_ptr m; mp_size_t new_size; { mpz_t m1; memcpy(m1, m, sizeof(mpz_t)); if (_mpz_realloc(m, new_size)) return m->_mp_d; else { if (m1->_mp_d) mpz_clear(m1); return NULL; } } static void *mpz_new(mpz_t z, mp_size_t sz) { mpz_init(z); if (z->_mp_d && my_mpz_realloc(z, sz)) return z->_mp_d; else return NULL; } static void *mpz_copy(mpz_t z, mpz_t u) { if (mpz_new(z, mpz_size(u))) { mpz_set(z, u); return z->_mp_d; } else return NULL; } static void *mpz_resize(mpz_t z, mp_size_t sz) { if (sz < mpz_size(z)) sz = mpz_size(z); if (sz == 0) sz = 1; if (sz != z->_mp_alloc && !my_mpz_realloc(z, sz)) return NULL; else return z->_mp_d; } #define mpz_actsize(z) mpz_resize(z, mpz_size(z)) #define abs(x) (((x)<0.0)?-x:x) static void *mpz_from_double(mpz_t z, double x) { double ip, fp, dsz; int sz; fp = modf(x, &ip); /* estimate the number of limbs required */ dsz = log(abs(ip))/log(2)/((double)CHAR_BIT*sizeof(mp_limb_t))+1.0; if (dsz < 1.0) dsz = 1.0; /* this can't happen?? */ /* add an extra limb to be safe */ sz = ((int)dsz)+1; /* this shouldn't happen but ... ;-) */ if (((double)INT_MAX) <= dsz || sz < 0) return NULL; if (mpz_new(z, sz)) { mpz_set_d(z, x); return mpz_actsize(z); } else return NULL; } static long long_max(long x, long y) { return (x > y)?x:y; } static long long_min(long x, long y) { return (x < y)?x:y; } static void *mpz_addop2(void (*f)(), mpz_t z, mpz_t u, mpz_t v) { int sz = long_max(mpz_size(u),mpz_size(v))+1; if (sz < 0) return NULL; if (mpz_new(z, sz)) { f(z, u, v); return mpz_actsize(z); } else return NULL; } static void *mpz_addop1(void (*f)(), mpz_t z, mpz_t u, mp_limb_t v) { int sz = mpz_size(u)+1; if (sz < 0) return NULL; if (mpz_new(z, sz)) { f(z, u, v); return mpz_actsize(z); } else return NULL; } /* reverse the limbs of an mpz_t value to convert between little- and big-endian limb order */ static void reverse_limbs(mp_limb_t *p, unsigned n) { unsigned i; for (i = 0; i < n/2; i++) { mp_limb_t x = p[i]; p[i] = p[n-i-1]; p[n-i-1] = x; } } #ifdef USE_THREADS static pthread_mutex_t format_mutex; #endif static void lock_format(void) { #ifdef USE_THREADS pthread_mutex_lock(&format_mutex); #endif } static void unlock_format(void) { #ifdef USE_THREADS pthread_mutex_unlock(&format_mutex); #endif } /* manifest constants */ /* data sizes */ #ifndef SIZEOF_CHAR #define SIZEOF_CHAR sizeof(char) #endif #ifndef SIZEOF_SHORT #define SIZEOF_SHORT sizeof(short) #endif #ifndef SIZEOF_INT #define SIZEOF_INT sizeof(int) #endif #ifndef SIZEOF_LONG #define SIZEOF_LONG sizeof(long) #endif #ifndef SIZEOF_LONG_LONG #if __GNUC__ > 1 #define SIZEOF_LONG_LONG sizeof(long long) #else /* can't be sure that this one exists */ #define SIZEOF_LONG_LONG 0 #endif #endif #ifndef SIZEOF_FLOAT #define SIZEOF_FLOAT sizeof(float) #endif #ifndef SIZEOF_DOUBLE #define SIZEOF_DOUBLE sizeof(double) #endif /* O_NDELAY and O_NONBLOCK are synonymous */ #ifndef O_NDELAY #ifdef O_NONBLOCK #define O_NDELAY O_NONBLOCK #else #define O_NDELAY 0 #endif #endif #ifndef O_NONBLOCK #define O_NONBLOCK O_NDELAY #endif #ifndef O_NOCTTY #define O_NOCTTY 0 #endif #ifndef O_BINARY #define O_BINARY 0 #endif #ifndef FD_CLOEXEC #define FD_CLOEXEC 0 #endif /* POSIX requires this one, but I am not sure whether it is defined on all systems */ #ifndef O_ACCMODE #define O_ACCMODE (O_RDONLY|O_WRONLY|O_RDWR) #endif /* File type bits. */ #ifndef S_IFBLK #define S_IFBLK 0 #endif #ifndef S_IFCHR #define S_IFCHR 0 #endif #ifndef S_IFIFO #define S_IFIFO 0 #endif #ifndef S_IFREG #define S_IFREG 0 #endif #ifndef S_IFDIR #define S_IFDIR 0 #endif #ifndef S_IFLNK #define S_IFLNK 0 #endif #ifndef S_IFSOCK #define S_IFSOCK 0 #endif #ifndef S_IFMT #define S_IFMT (S_IFMT|S_IFBLK|S_IFCHR|S_IFIFO|S_IFREG|S_IFDIR|S_IFLNK|S_IFSOCK) #endif /* Fcntl command codes. */ #ifndef F_DUPFD #define F_DUPFD (-1) #endif #ifndef F_GETFD #define F_GETFD (-1) #endif #ifndef F_SETFD #define F_SETFD (-1) #endif #ifndef F_GETFL #define F_GETFL (-1) #endif #ifndef F_SETFL #define F_SETFL (-1) #endif #ifndef F_GETLK #define F_GETLK (-1) #endif #ifndef F_SETLK #define F_SETLK (-1) #endif #ifndef F_SETLKW #define F_SETLKW (-1) #endif /* Lock types. */ #ifndef F_RDLCK #define F_RDLCK (-1) #endif #ifndef F_WRLCK #define F_WRLCK (-1) #endif #ifndef F_UNLCK #define F_UNLCK (-1) #endif /* Access options. */ #ifndef F_OK #define F_OK 0 #endif #ifndef R_OK #define R_OK 0 #endif #ifndef W_OK #define W_OK 0 #endif #ifndef X_OK #define X_OK 0 #endif /* Wait options. */ #ifndef WNOHANG #define WNOHANG 0 #endif #ifndef WUNTRACED #define WUNTRACED 0 #endif /* Time units. */ #ifndef CLK_TCK #ifdef HAVE_SYSCONF #define CLK_TCK sysconf(_SC_CLK_TCK) #else #define CLK_TCK 0 #endif #endif /* Signal numbers. */ #ifdef SIGABRT #define _SIGABRT SIGABRT #else #define _SIGABRT (-1) #endif #ifdef SIGALRM #define _SIGALRM SIGALRM #else #define _SIGALRM (-1) #endif #ifdef SIGFPE #define _SIGFPE SIGFPE #else #define _SIGFPE (-1) #endif #ifdef SIGHUP #define _SIGHUP SIGHUP #else #define _SIGHUP (-1) #endif #ifdef SIGILL #define _SIGILL SIGILL #else #define _SIGILL (-1) #endif #ifdef SIGINT #define _SIGINT SIGINT #else #define _SIGINT (-1) #endif #ifdef SIGKILL #define _SIGKILL SIGKILL #else #define _SIGKILL (-1) #endif #ifdef SIGPIPE #define _SIGPIPE SIGPIPE #else #define _SIGPIPE (-1) #endif #ifdef SIGQUIT #define _SIGQUIT SIGQUIT #else #define _SIGQUIT (-1) #endif #ifdef SIGSEGV #define _SIGSEGV SIGSEGV #else #define _SIGSEGV (-1) #endif #ifdef SIGTERM #define _SIGTERM SIGTERM #else #define _SIGTERM (-1) #endif #ifdef SIGUSR1 #define _SIGUSR1 SIGUSR1 #else #define _SIGUSR1 (-1) #endif #ifdef SIGUSR2 #define _SIGUSR2 SIGUSR2 #else #define _SIGUSR2 (-1) #endif #ifdef SIGCHLD #define _SIGCHLD SIGCHLD #else #define _SIGCHLD (-1) #endif #ifdef SIGCONT #define _SIGCONT SIGCONT #else #define _SIGCONT (-1) #endif #ifdef SIGSTOP #define _SIGSTOP SIGSTOP #else #define _SIGSTOP (-1) #endif #ifdef SIGTSTP #define _SIGTSTP SIGTSTP #else #define _SIGTSTP (-1) #endif #ifdef SIGTTIN #define _SIGTTIN SIGTTIN #else #define _SIGTTIN (-1) #endif #ifdef SIGTTOU #define _SIGTTOU SIGTTOU #else #define _SIGTTOU (-1) #endif #ifdef SIGBUS #define _SIGBUS SIGBUS #else #define _SIGBUS (-1) #endif #ifdef SIGPOLL #define _SIGPOLL SIGPOLL #else #define _SIGPOLL (-1) #endif #ifdef SIGPROF #define _SIGPROF SIGPROF #else #define _SIGPROF (-1) #endif #ifdef SIGSYS #define _SIGSYS SIGSYS #else #define _SIGSYS (-1) #endif #ifdef SIGTRAP #define _SIGTRAP SIGTRAP #else #define _SIGTRAP (-1) #endif #ifdef SIGURG #define _SIGURG SIGURG #else #define _SIGURG (-1) #endif #ifdef SIGVTALRM #define _SIGVTALRM SIGVTALRM #else #define _SIGVTALRM (-1) #endif #ifdef SIGXCPU #define _SIGXCPU SIGXCPU #else #define _SIGXCPU (-1) #endif #ifdef SIGXFSZ #define _SIGXFSZ SIGXFSZ #else #define _SIGXFSZ (-1) #endif /* Termios constants. */ #ifndef TCSANOW #define TCSANOW (-1) #endif #ifndef TCSADRAIN #define TCSADRAIN (-1) #endif #ifndef TCSAFLUSH #define TCSAFLUSH (-1) #endif #ifndef TCIFLUSH #define TCIFLUSH (-1) #endif #ifndef TCIOFLUSH #define TCIOFLUSH (-1) #endif #ifndef TCOFLUSH #define TCOFLUSH (-1) #endif #ifndef TCIOFF #define TCIOFF (-1) #endif #ifndef TCION #define TCION (-1) #endif #ifndef TCOOFF #define TCOOFF (-1) #endif #ifndef TCOON #define TCOON (-1) #endif #ifndef BRKINT #define BRKINT 0 #endif #ifndef ICRNL #define ICRNL 0 #endif #ifndef IGNBRK #define IGNBRK 0 #endif #ifndef IGNCR #define IGNCR 0 #endif #ifndef IGNPAR #define IGNPAR 0 #endif #ifndef INLCR #define INLCR 0 #endif #ifndef INPCK #define INPCK 0 #endif #ifndef ISTRIP #define ISTRIP 0 #endif #ifndef IUCLC #define IUCLC 0 #endif #ifndef IXANY #define IXANY 0 #endif #ifndef IXOFF #define IXOFF 0 #endif #ifndef IXON #define IXON 0 #endif #ifndef PARMRK #define PARMRK 0 #endif #ifndef OPOST #define OPOST 0 #endif #ifndef OLCUC #define OLCUC 0 #endif #ifndef ONLCR #define ONLCR 0 #endif #ifndef OCRNL #define OCRNL 0 #endif #ifndef ONOCR #define ONOCR 0 #endif #ifndef ONLRET #define ONLRET 0 #endif #ifndef OFILL #define OFILL 0 #endif #ifndef NLDLY #define NLDLY 0 #endif #ifndef NL0 #define NL0 0 #endif #ifndef NL1 #define NL1 0 #endif #ifndef CRDLY #define CRDLY 0 #endif #ifndef CR0 #define CR0 0 #endif #ifndef CR1 #define CR1 0 #endif #ifndef CR2 #define CR2 0 #endif #ifndef CR3 #define CR3 0 #endif #ifndef TABDLY #define TABDLY 0 #endif #ifndef TAB0 #define TAB0 0 #endif #ifndef TAB1 #define TAB1 0 #endif #ifndef TAB2 #define TAB2 0 #endif #ifndef TAB3 #define TAB3 0 #endif #ifndef BSDLY #define BSDLY 0 #endif #ifndef BS0 #define BS0 0 #endif #ifndef BS1 #define BS1 0 #endif #ifndef VTDLY #define VTDLY 0 #endif #ifndef VT0 #define VT0 0 #endif #ifndef VT1 #define VT1 0 #endif #ifndef FFDLY #define FFDLY 0 #endif #ifndef FF0 #define FF0 0 #endif #ifndef FF1 #define FF1 0 #endif #ifndef CSIZE #define CSIZE 0 #endif #ifndef CS5 #define CS5 0 #endif #ifndef CS6 #define CS6 0 #endif #ifndef CS7 #define CS7 0 #endif #ifndef CS8 #define CS8 0 #endif #ifndef CSTOPB #define CSTOPB 0 #endif #ifndef CREAD #define CREAD 0 #endif #ifndef PARENB #define PARENB 0 #endif #ifndef PARODD #define PARODD 0 #endif #ifndef HUPCL #define HUPCL 0 #endif #ifndef CLOCAL #define CLOCAL 0 #endif #ifndef ECHO #define ECHO 0 #endif #ifndef ECHOE #define ECHOE 0 #endif #ifndef ECHOK #define ECHOK 0 #endif #ifndef ECHONL #define ECHONL 0 #endif #ifndef ICANON #define ICANON 0 #endif #ifndef IEXTEN #define IEXTEN 0 #endif #ifndef ISIG #define ISIG 0 #endif #ifndef NOFLSH #define NOFLSH 0 #endif #ifndef TOSTOP #define TOSTOP 0 #endif #ifndef XCASE #define XCASE 0 #endif #ifndef B0 #define B0 (-1) #endif #ifndef B50 #define B50 (-1) #endif #ifndef B75 #define B75 (-1) #endif #ifndef B110 #define B110 (-1) #endif #ifndef B134 #define B134 (-1) #endif #ifndef B150 #define B150 (-1) #endif #ifndef B200 #define B200 (-1) #endif #ifndef B300 #define B300 (-1) #endif #ifndef B600 #define B600 (-1) #endif #ifndef B1200 #define B1200 (-1) #endif #ifndef B1800 #define B1800 (-1) #endif #ifndef B2400 #define B2400 (-1) #endif #ifndef B4800 #define B4800 (-1) #endif #ifndef B9600 #define B9600 (-1) #endif #ifndef B19200 #define B19200 (-1) #endif #ifndef B38400 #define B38400 (-1) #endif #ifndef VEOF #define VEOF (-1) #endif #ifndef VEOL #define VEOL (-1) #endif #ifndef VERASE #define VERASE (-1) #endif #ifndef VINTR #define VINTR (-1) #endif #ifndef VKILL #define VKILL (-1) #endif #ifndef VMIN #define VMIN (-1) #endif #ifndef VQUIT #define VQUIT (-1) #endif #ifndef VSTART #define VSTART (-1) #endif #ifndef VSTOP #define VSTOP (-1) #endif #ifndef VSUSP #define VSUSP (-1) #endif #ifndef VTIME #define VTIME (-1) #endif /* legacy stuff */ #ifndef IUCLC #define IUCLC 0 #endif #ifndef OLCUC #define OLCUC 0 #endif #ifndef XCASE #define XCASE 0 #endif /* Socket-related stuff. */ #ifndef HAVE_BSD_SOCKETS #define AF_LOCAL (-1) #define AF_INET (-1) #define AF_INET6 (-1) #define SOCK_STREAM (-1) #define SOCK_DGRAM (-1) #define SOCK_SEQPACKET (-1) #define SOCK_RAW (-1) #define SOCK_RDM (-1) #define SHUT_RD (-1) #define SHUT_WR (-1) #define SHUT_RDWR (-1) #define MSG_EOR (-1) #define MSG_OOB (-1) #define MSG_PEEK (-1) #define MSG_WAITALL (-1) #define SOL_SOCKET (-1) #define SO_ACCEPTCONN (-1) #define SO_BROADCAST (-1) #define SO_DEBUG (-1) #define SO_DONTROUTE (-1) #define SO_ERROR (-1) #define SO_KEEPALIVE (-1) #define SO_LINGER (-1) #define SO_OOBINLINE (-1) #define SO_RCVBUF (-1) #define SO_RCVLOWAT (-1) #define SO_RCVTIMEO (-1) #define SO_REUSEADDR (-1) #define SO_SNDBUF (-1) #define SO_SNDLOWAT (-1) #define SO_SNDTIMEO (-1) #define SO_TYPE (-1) #define IPPROTO_IP (-1) #define IPPROTO_ICMP (-1) #define IPPROTO_TCP (-1) #define IPPROTO_UDP (-1) #else #if !defined(AF_LOCAL) && defined(PF_LOCAL) #define AF_LOCAL PF_LOCAL #endif #if !defined(AF_INET) && defined(PF_INET) #define AF_INET PF_INET #endif #if !defined(AF_INET6) && defined(PF_INET6) #define AF_INET6 PF_INET6 #endif #ifndef SOCK_RAW #define SOCK_RAW (-1) #endif #ifndef SOCK_RDM #define SOCK_RDM (-1) #endif #ifndef SOCK_SEQPACKET #define SOCK_SEQPACKET (-1) #endif #ifndef SHUT_RD #define SHUT_RD 0 #endif #ifndef SHUT_WR #define SHUT_WR 1 #endif #ifndef SHUT_RDWR #define SHUT_RDWR 2 #endif #ifndef MSG_EOR #define MSG_EOR 0 #endif #ifndef MSG_PEEK #define MSG_PEEK 0 #endif #ifndef MSG_WAITALL #define MSG_WAITALL 0 #endif #ifndef SO_ACCEPTCONN #define SO_ACCEPTCONN (-1) #endif #ifndef SO_BROADCAST #define SO_BROADCAST (-1) #endif #ifndef SO_DONTROUTE #define SO_DONTROUTE (-1) #endif #ifndef SO_ERROR #define SO_ERROR (-1) #endif #ifndef SO_KEEPALIVE #define SO_KEEPALIVE (-1) #endif #ifndef SO_LINGER #define SO_LINGER (-1) #endif #ifndef SO_OOBINLINE #define SO_OOBINLINE (-1) #endif #ifndef SO_RCVBUF #define SO_RCVBUF (-1) #endif #ifndef SO_RCVLOWAT #define SO_RCVLOWAT (-1) #endif #ifndef SO_RCVTIMEO #define SO_RCVTIMEO (-1) #endif #ifndef SO_SNDBUF #define SO_SNDBUF (-1) #endif #ifndef SO_SNDLOWAT #define SO_SNDLOWAT (-1) #endif #ifndef SO_SNDTIMEO #define SO_SNDTIMEO (-1) #endif #ifndef SO_TYPE #define SO_TYPE (-1) #endif #ifndef IPPROTO_IP #define IPPROTO_IP 0 #endif #ifndef INADDR_NONE #define INADDR_NONE ((in_addr_t)(-1)) #endif #ifndef HAVE_SOCKLEN_T #define socklen_t int #endif #ifndef HAVE_IN_PORT_T #define in_port_t short #endif #ifndef HAVE_IN_ADDR_T #define in_addr_t int #endif #ifndef HAVE_UINT16_T #define uint16_t unsigned short #endif #endif #ifndef SEEK_SET #define SEEK_SET 0 #endif #ifndef SEEK_CUR #define SEEK_CUR 1 #endif #ifndef SEEK_END #define SEEK_END 2 #endif #ifndef P_WAIT #define P_WAIT 0 #define P_NOWAIT 1 #define P_OVERLAY 2 #define P_DETACH 4 #endif FUNCTION(clib,sys_vars,argc,argv) { if (argc != 0) return __FAIL; return mktuplel (221, mkint(SIZEOF_CHAR), mkint(SIZEOF_SHORT), mkint(SIZEOF_INT), mkint(SIZEOF_LONG), mkint(SIZEOF_LONG_LONG), mkint(SIZEOF_FLOAT), mkint(SIZEOF_DOUBLE), mkint(P_WAIT), mkint(P_NOWAIT), mkint(P_OVERLAY), mkint(P_DETACH), mkint(_IONBF), mkint(_IOLBF), mkint(_IOFBF), mkint(SEEK_SET), mkint(SEEK_CUR), mkint(SEEK_END), mkint(O_RDONLY), mkint(O_WRONLY), mkint(O_RDWR), mkint(O_ACCMODE), mkint(FD_CLOEXEC), mkint(O_CREAT), mkint(O_EXCL), mkint(O_TRUNC), mkint(O_APPEND), mkint(O_NONBLOCK), mkint(O_NDELAY), mkint(O_NOCTTY), mkint(O_BINARY), mkint(S_IFMT), mkint(S_IFBLK), mkint(S_IFCHR), mkint(S_IFIFO), mkint(S_IFREG), mkint(S_IFDIR), mkint(S_IFLNK), mkint(S_IFSOCK), mkint(F_DUPFD), mkint(F_GETFD), mkint(F_SETFD), mkint(F_GETFL), mkint(F_SETFL), mkint(F_GETLK), mkint(F_SETLK), mkint(F_SETLKW), mkint(F_RDLCK), mkint(F_WRLCK), mkint(F_UNLCK), mkint(F_OK), mkint(R_OK), mkint(W_OK), mkint(X_OK), mkint(WNOHANG), mkint(WUNTRACED), mkint((long)CLOCKS_PER_SEC), mkint((long)CLK_TCK), mkint(_SIGABRT), mkint(_SIGALRM), mkint(_SIGFPE), mkint(_SIGHUP), mkint(_SIGILL), mkint(_SIGINT), mkint(_SIGKILL), mkint(_SIGPIPE), mkint(_SIGQUIT), mkint(_SIGSEGV), mkint(_SIGTERM), mkint(_SIGUSR1), mkint(_SIGUSR2), mkint(_SIGCHLD), mkint(_SIGCONT), mkint(_SIGSTOP), mkint(_SIGTSTP), mkint(_SIGTTIN), mkint(_SIGTTOU), mkint(_SIGBUS), mkint(_SIGPOLL), mkint(_SIGPROF), mkint(_SIGSYS), mkint(_SIGTRAP), mkint(_SIGURG), mkint(_SIGVTALRM), mkint(_SIGXCPU), mkint(_SIGXFSZ), mkint(TCSANOW), mkint(TCSADRAIN), mkint(TCSAFLUSH), mkint(TCIFLUSH), mkint(TCIOFLUSH), mkint(TCOFLUSH), mkint(TCIOFF), mkint(TCION), mkint(TCOOFF), mkint(TCOON), mkint(BRKINT), mkint(ICRNL), mkint(IGNBRK), mkint(IGNCR), mkint(IGNPAR), mkint(INLCR), mkint(INPCK), mkint(ISTRIP), mkint(IUCLC), mkint(IXANY), mkint(IXOFF), mkint(IXON), mkint(PARMRK), mkint(OPOST), mkint(OLCUC), mkint(ONLCR), mkint(OCRNL), mkint(ONOCR), mkint(ONLRET), mkint(OFILL), mkint(NLDLY), mkint(NL0), mkint(NL1), mkint(CRDLY), mkint(CR0), mkint(CR1), mkint(CR2), mkint(CR3), mkint(TABDLY), mkint(TAB0), mkint(TAB1), mkint(TAB2), mkint(TAB3), mkint(BSDLY), mkint(BS0), mkint(BS1), mkint(VTDLY), mkint(VT0), mkint(VT1), mkint(FFDLY), mkint(FF0), mkint(FF1), mkint(CSIZE), mkint(CS5), mkint(CS6), mkint(CS7), mkint(CS8), mkint(CSTOPB), mkint(CREAD), mkint(PARENB), mkint(PARODD), mkint(HUPCL), mkint(CLOCAL), mkint(ECHO), mkint(ECHOE), mkint(ECHOK), mkint(ECHONL), mkint(ICANON), mkint(IEXTEN), mkint(ISIG), mkint(NOFLSH), mkint(TOSTOP), mkint(XCASE), mkint(B0), mkint(B50), mkint(B75), mkint(B110), mkint(B134), mkint(B150), mkint(B200), mkint(B300), mkint(B600), mkint(B1200), mkint(B1800), mkint(B2400), mkint(B4800), mkint(B9600), mkint(B19200), mkint(B38400), mkint(VEOF), mkint(VEOL), mkint(VERASE), mkint(VINTR), mkint(VKILL), mkint(VMIN), mkint(VQUIT), mkint(VSTART), mkint(VSTOP), mkint(VSUSP), mkint(VTIME), #ifdef AF_LOCAL mkint(AF_LOCAL), #else /* not supported on Windows */ mkint(-1), #endif #ifdef AF_INET mkint(AF_INET), #else mkint(-1), #endif #ifdef AF_INET6 mkint(AF_INET6), #else mkint(-1), #endif mkint(SOCK_STREAM), mkint(SOCK_DGRAM), mkint(SOCK_RAW), mkint(SOCK_RDM), mkint(SOCK_SEQPACKET), mkint(SHUT_RD), mkint(SHUT_WR), mkint(SHUT_RDWR), mkint(MSG_EOR), mkint(MSG_OOB), mkint(MSG_PEEK), mkint(MSG_WAITALL), mkint(SOL_SOCKET), mkint(SO_ACCEPTCONN), mkint(SO_BROADCAST), mkint(SO_DEBUG), mkint(SO_DONTROUTE), mkint(SO_ERROR), mkint(SO_KEEPALIVE), mkint(SO_LINGER), mkint(SO_OOBINLINE), mkint(SO_RCVBUF), mkint(SO_RCVLOWAT), mkint(SO_RCVTIMEO), mkint(SO_REUSEADDR), mkint(SO_SNDBUF), mkint(SO_SNDLOWAT), mkint(SO_SNDTIMEO), mkint(SO_TYPE), mkint(IPPROTO_IP), mkint(IPPROTO_ICMP), mkint(IPPROTO_TCP), mkint(IPPROTO_UDP) ); } /* additional string functions: *******************************************/ FUNCTION(clib,islower,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (islower(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isupper,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isupper(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isalpha,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isalpha(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isdigit,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isdigit(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isxdigit,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isxdigit(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isalnum,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isalnum(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,ispunct,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (ispunct(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isspace,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isspace(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isgraph,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isgraph(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isprint,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isprint(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,iscntrl,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (iscntrl(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,isascii,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) if (isascii(*s)) return mktrue; else return mkfalse; else return __FAIL; } FUNCTION(clib,tolower,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s)) { char *t = strdup(s); if (t) { int i; for (i = 0; i < strlen(t); i++) t[i] = tolower(t[i]); return mkstr(t); } else return __ERROR; } else return __FAIL; } FUNCTION(clib,toupper,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s)) { char *t = strdup(s); if (t) { int i; for (i = 0; i < strlen(t); i++) t[i] = toupper(t[i]); return mkstr(t); } else return __ERROR; } else return __FAIL; } /* byte strings: ************************************************************/ typedef struct bstr { long size; unsigned char *v; } bstr_t; DESTRUCTOR(clib,ByteStr,ptr) { bstr_t *m = (bstr_t*)ptr; if (m) { if (m->v) free(m->v); free(m); } } static expr mkbstr(long size, void *v) { bstr_t *m; if ((m = malloc(sizeof(bstr_t)))) { m->size = size; m->v = (unsigned char*)v; return mkobj(type(ByteStr), m); } else { if (v) free(v); return __ERROR; } } FUNCTION(clib,bytestr,argc,argv) { expr x, hd, tl, *xv; int k; long count = -1; mpz_t z; double d; float f; char *s; unsigned char *v = NULL; if (argc != 1) return __FAIL; if (iscons(argv[0], &hd, &tl) || isnil(argv[0])) { long n, b; for (n = 0, x = argv[0]; iscons(x, &hd, &tl) && isint(hd, &b) && b>=0 && b<=0xff; x = tl) if (n > 0 && n+1 <= 0) return __ERROR; else n++; if (!isnil(x)) return __FAIL; count = n; if (count && !(v = malloc(count))) return __ERROR; if (v) memset(v, 0, count); for (n = 0, x = argv[0]; n < count && iscons(x, &hd, &tl) && isint(hd, &b); x = tl) v[n++] = (unsigned char)b; return mkbstr(count, v); } if (istuple(argv[0], &k, &xv) && k == 2 && isint(xv[1], &count)) { if (count < 0) return __FAIL; x = xv[0]; } else x = argv[0]; if (ismpz(x, z)) { unsigned long n; long c; unsigned char pad_byte = 0; mpz_t u; n = mpz_size(z); if (count < 0) count = ((n>0)?n:1)*sizeof(mp_limb_t); c = count; if (c % sizeof(mp_limb_t) > 0) c = (c/sizeof(mp_limb_t)+1)*sizeof(mp_limb_t); if (c < 0) return __ERROR; if (c && !(v = malloc(c))) return __ERROR; if (!mpz_new(u, n)) { if (v) free(v); return __ERROR; } mpz_set(u, z); if (mpz_sgn(z) < 0) { unsigned long j; pad_byte = 0xff; /* 2's complement */ for (j = 0; j < n; j++) u->_mp_d[j] = ~u->_mp_d[j]; mpn_add_1(u->_mp_d, u->_mp_d, n, 1U); } if (c/sizeof(mp_limb_t) < n) n = c/sizeof(mp_limb_t); if (v) { memset(v, pad_byte, count); memcpy(v, u->_mp_d, n*sizeof(mp_limb_t)); #ifdef WORDS_BIGENDIAN /* correct last limb on big-endian systems */ if (count < c && c/sizeof(mp_limb_t) == n) memmove(v+c-sizeof(mp_limb_t), v+c-sizeof(mp_limb_t)+(c-count), sizeof(mp_limb_t)-(c-count)); #endif if (count != c) { unsigned char *v1 = realloc(v, count); if (v1) v = v1; } } mpz_clear(u); } else if (isfloat(x, &d)) { f = (float)d; if (count < 0) count = sizeof(double); if (count && !(v = malloc(count))) return __ERROR; if (v) memset(v, 0, count); if (count >= sizeof(double)) memcpy(v, &d, sizeof(double)); else if (count >= sizeof(float)) memcpy(v, &f, sizeof(float)); else memcpy(v, &f, count); } else if (isstr(x, &s)) { if (count < 0) count = strlen(s); if (count && !(v = malloc(count))) return __ERROR; if (v) memset(v, 0, count); if (v) strncpy((char*)v, s, count); } else return __FAIL; return mkbstr(count, v); } FUNCTION(clib,bcat,argc,argv) { bstr_t *m; unsigned char *v = NULL; expr x, hd, tl; long n; if (argc != 1) return __FAIL; for (n = 0, x = argv[0]; iscons(x, &hd, &tl) && isobj(hd, type(ByteStr), (void**)&m); x = tl) if (n > 0 && n+m->size <= 0) return __ERROR; else n += m->size; if (!isnil(x)) return __FAIL; if (n && !(v = malloc(n))) return __ERROR; for (n = 0, x = argv[0]; iscons(x, &hd, &tl) && isobj(hd, type(ByteStr), (void**)&m); x = tl, n += m->size) memcpy(v+n, m->v, m->size); return mkbstr(n, v); } FUNCTION(clib,bsize,argc,argv) { bstr_t *m; if (argc == 1 && isobj(argv[0], type(ByteStr), (void**)&m)) return mkint(m->size); else return __FAIL; } FUNCTION(clib,byte,argc,argv) { bstr_t *m; long i; if (argc == 2 && isint(argv[0], &i) && isobj(argv[1], type(ByteStr), (void**)&m) && i >= 0 && i < m->size) return mkint(m->v[i]); else return __FAIL; } FUNCTION(clib,bsub,argc,argv) { bstr_t *m; void *v = NULL; long i, j, c, l; if (argc == 3 && isobj(argv[0], type(ByteStr), (void**)&m) && isint(argv[1], &i) && isint(argv[2], &j)) { if (i < 0) i = 0; c = j-i+1; l = m->size; if (i >= l || j < i) l = 0; else if ((l -= i) > c) l = c; if (l < 0) l = 0; if (l && !(v = malloc(l))) return __ERROR; if (l) memcpy(v, m->v+i, l); return mkbstr(l, v); } else return __FAIL; } FUNCTION(clib,bcmp,argc,argv) { bstr_t *m1, *m2; if (argc == 2 && isobj(argv[0], type(ByteStr), (void**)&m1) && isobj(argv[1], type(ByteStr), (void**)&m2)) if (!m1->v) if (!m2->v) return mkint(0); else return mkint(-1); else if (!m2->v) return mkint(1); else { long i, n = m1->size, res; if (n > m2->size) n = m2->size; res = memcmp(m1->v, m2->v, n); if (res == 0) if (m1->size < m2->size) res = -1; else if (m1->size > m2->size) res = 1; return mkint(res); } else return __FAIL; } FUNCTION(clib,bint,argc,argv) { bstr_t *m; if (argc == 1 && isobj(argv[0], type(ByteStr), (void**)&m)) { long n = m->size/sizeof(mp_limb_t), k = m->size%sizeof(mp_limb_t), c; mpz_t z; if (k > 0) n++; if (mpz_new(z, n)) { memset(z->_mp_d, 0, n*sizeof(mp_limb_t)); #ifdef WORDS_BIGENDIAN c = n*sizeof(mp_limb_t)-m->size; if (c > 0) { memcpy(z->_mp_d, m->v, m->size-k); memcpy(((unsigned char*)z->_mp_d)+(n-1)*sizeof(mp_limb_t)+c, m->v+(n-1)*sizeof(mp_limb_t), k); } else #endif memcpy(z->_mp_d, m->v, m->size); while (n > 0 && !z->_mp_d[n-1]) n--; z->_mp_size = n; if (!mpz_actsize(z)) return __FAIL; else return mkmpz(z); } else return __ERROR; } else return __FAIL; } FUNCTION(clib,bfloat,argc,argv) { bstr_t *m; if (argc == 1 && isobj(argv[0], type(ByteStr), (void**)&m)) { if (m->size >= sizeof(double)) { double d; memcpy(&d, m->v, sizeof(double)); return mkfloat(d); } else if (m->size >= sizeof(float)) { float f; memcpy(&f, m->v, sizeof(float)); return mkfloat((double)f); } else { float f; memset(&f, 0, sizeof(float)); memcpy(&f, m->v, m->size); return mkfloat((double)f); } } else return __FAIL; } FUNCTION(clib,bstr,argc,argv) { bstr_t *m; if (argc == 1 && isobj(argv[0], type(ByteStr), (void**)&m)) { char *s = malloc(m->size+1), *s1; if (!s) return __ERROR; if (m->size) memcpy(s, m->v, m->size); s[m->size] = 0; if ((s1 = realloc(s, strlen(s)+1))) s = s1; return mkstr(s); } } /* enhanced file functions: ***********************************************/ FUNCTION(clib,fopen,argc,argv) { char *name, *mode; FILE *fp; if (argc != 2 || !isstr(argv[0], &name) || !isstr(argv[1], &mode)) return __FAIL; if (!strchr("rwa", mode[0]) || mode[1] && !strchr("b+", mode[1]) || mode[1] && mode[2] && (mode[1] == mode[2] || !strchr("b+", mode[2]))) return __FAIL; release_lock(); fp = fopen(name, mode); acquire_lock(); if (fp) return mkfile(fp); else return __FAIL; } FUNCTION(clib,fdopen,argc,argv) { long fd; char *mode; FILE *fp; if (argc != 2 || !isint(argv[0], &fd) || !isstr(argv[1], &mode)) return __FAIL; if (!strchr("rwa", mode[0]) || mode[1] && !strchr("b+", mode[1]) || mode[1] && mode[2] && (mode[1] == mode[2] || !strchr("b+", mode[2]))) return __FAIL; fp = fdopen(fd, mode); if (fp) return mkfile(fp); else return __FAIL; } FUNCTION(clib,freopen,argc,argv) { char *name, *mode; FILE *fp; if (argc != 3 || !isstr(argv[0], &name) || !isstr(argv[1], &mode) || !isfile(argv[2], &fp)) return __FAIL; if (!strchr("rwa", mode[0]) || mode[1] && !strchr("b+", mode[1]) || mode[1] && mode[2] && (mode[1] == mode[2] || !strchr("b+", mode[2]))) return __FAIL; if (freopen(name, mode, fp)) return argv[2]; else return __FAIL; } FUNCTION(clib,fileno,argc,argv) { FILE *fp; if (argc != 1 || !isfile(argv[0], &fp)) return __FAIL; else return mkint(fileno(fp)); } FUNCTION(clib,setvbuf,argc,argv) { FILE *fp; long mode; if (argc != 2 || !isfile(argv[0], &fp) || !isint(argv[1], &mode) || setvbuf(fp, NULL, mode, 0)) return __FAIL; else return mkvoid; } FUNCTION(clib,tmpnam,argc,argv) { if (argc == 0) { #ifdef __MINGW32__ /* win32 tmpnam is broken, provide a reasonable replacement */ char *s = _tempnam("\\tmp", "t"), *p; /* make sure to convert all \'s to /'s */ while ((p = strchr(s, '\\'))) *p = '/'; return mkstr(s); #else char s[L_tmpnam]; tmpnam(s); return mkstr(strdup(s)); #endif } else return __FAIL; } FUNCTION(clib,tmpfile,argc,argv) { if (argc == 0) { FILE * fp = tmpfile(); if (fp) return mkfile(fp); else return __FAIL; } else return __FAIL; } FUNCTION(clib,ftell,argc,argv) { FILE *fp; long res; if (argc != 1 || !isfile(argv[0], &fp)) return __FAIL; res = ftell(fp); if (res >= 0) return mkint(res); else return __FAIL; } FUNCTION(clib,fseek,argc,argv) { FILE *fp; long pos, whence; int res; if (argc != 3 || !isfile(argv[0], &fp) || !isint(argv[1], &pos) || !isint(argv[2], &whence)) return __FAIL; res = fseek(fp, pos, whence); if (res) return __FAIL; else return mkvoid; } #ifdef HAVE_SELECT static int getfds(expr x, fd_set *set) { expr hd, tl; FILE *fp; long i; int n = -1; FD_ZERO(set); while (iscons(x, &hd, &tl)) { int fd; if (isfile(hd, &fp)) fd = fileno(fp); else if (isint(hd, &i)) fd = (int)i; else break; if (fd > n) n = fd; FD_SET(fd, set); x = tl; } if (isnil(x)) return n+1; else return -1; } static expr listfds(expr x, fd_set *set) { expr *ys, y, hd, tl; FILE *fp; long i; int n; for (n = 0, y = x; iscons(y, &hd, &tl); y = tl) if (isfile(hd, &fp) && FD_ISSET(fileno(fp), set) || isint(hd, &i) && FD_ISSET((int)i, set)) n++; if (!(ys = malloc(n*sizeof(expr)))) return NULL; for (n = 0, y = x; iscons(y, &hd, &tl); y = tl) if (isfile(hd, &fp) && FD_ISSET(fileno(fp), set) || isint(hd, &i) && FD_ISSET((int)i, set)) ys[n++] = hd; return mklistv(n, ys); } #endif FUNCTION(clib,select,argc,argv) { #ifdef HAVE_SELECT long ti; double tf; struct timeval tv, *timeout = NULL; fd_set in, out, err; int n, n_in, n_out, n_err; expr *xs, x; if (argc != 1 || !istuple(argv[0], &n, &xs) || (n != 3 && n != 4) || (n_in = getfds(xs[0], &in)) < 0 || (n_out = getfds(xs[1], &out)) < 0 || (n_err = getfds(xs[2], &err)) < 0) return __FAIL; if (n == 4) /* decode timeout argument */ if (isint(xs[3], &ti)) if (ti >= 0) { tv.tv_sec = ti; tv.tv_usec = 0; timeout = &tv; } else return __FAIL; else if (isfloat(xs[3], &tf)) if (tf >= 0.0) { double ip, fp; if (tf > LONG_MAX) tf = LONG_MAX; fp = modf(tf, &ip); tv.tv_sec = (unsigned long)ip; tv.tv_usec = (unsigned long)(fp*1e6); timeout = &tv; } else return __FAIL; else return __FAIL; n = n_in; if (n_out > n) n = n_out; if (n_err > n) n = n_err; release_lock(); n = select(n, &in, &out, &err, timeout); acquire_lock(); if (n >= 0) { expr x = mktuplel(3, listfds(xs[0], &in), listfds(xs[1], &out), listfds(xs[2], &err)); return x?x:__ERROR; } else return __FAIL; #else return __FAIL; #endif } FUNCTION(clib,fgets,argc,argv) { FILE *fp; char *s, *t, *r; int a, l; if (argc != 1 || !isfile(argv[0], &fp)) return __FAIL; s = malloc(BUFSZ); t = s; a = BUFSZ; if (!s) return __ERROR; *s = 0; release_lock(); if (fp == stdin) acquire_tty(); while ((r = fgets(t, BUFSZ, fp)) && *t && t[(l = strlen(t))-1] != '\n') { /* try to enlarge the buffer: */ int k = t-s+l; char *s1; if (s1 = (char*) realloc(s, a+BUFSZ)) { s = s1; t = s+k; a += BUFSZ; } else { free(s); if (fp == stdin) release_tty(); acquire_lock(); return __ERROR; } } if (ferror(fp)) { clearerr(fp); free(s); if (fp == stdin) release_tty(); acquire_lock(); return __FAIL; } if ((t = realloc(s, strlen(s)+1))) s = t; if (!r && !*s) { free(s); if (fp == stdin) release_tty(); acquire_lock(); return __FAIL; } if (fp == stdin) release_tty(); acquire_lock(); return mkstr(s); } FUNCTION(clib,gets,argc,argv) { if (argc == 0) { expr input = eval(mksym(sym(INPUT))); if (input) { expr argv1[1] = { input }; expr ret = FUNCALL(clib, fgets, 1, argv1); dispose(input); return ret; } else return __FAIL; } else return __FAIL; } FUNCTION(clib,fget,argc,argv) { FILE *fp; char *s, *t; int a; if (argc != 1 || !isfile(argv[0], &fp)) return __FAIL; s = malloc(BUFSZ); t = s; a = BUFSZ; if (!s) return __ERROR; *s = 0; release_lock(); if (fp == stdin) acquire_tty(); while (fgets(t, BUFSZ, fp)) { /* try to enlarge the buffer: */ int l = strlen(t), k = t-s+l; char *s1; if (s1 = (char*) realloc(s, a+BUFSZ)) { s = s1; t = s+k; a += BUFSZ; } else { free(s); if (fp == stdin) release_tty(); acquire_lock(); return __ERROR; } } if (ferror(fp)) { clearerr(fp); free(s); if (fp == stdin) release_tty(); acquire_lock(); return __FAIL; } if ((t = realloc(s, strlen(s)+1))) s = t; if (fp == stdin) release_tty(); acquire_lock(); return mkstr(s); } FUNCTION(clib,ungetc,argc,argv) { FILE *fp; char *s; if (argc == 1 && isstr(argv[0], &s) && s[0] && !s[1]) { expr input = eval(mksym(sym(INPUT))); if (isfile(input, &fp) && ungetc(s[0], fp) != EOF) return mkvoid; else return __FAIL; } else return __FAIL; } FUNCTION(clib,fungetc,argc,argv) { FILE *fp; char *s; if (argc == 2 && isfile(argv[0], &fp) && isstr(argv[1], &s) && s[0] && !s[1]) if (ungetc(s[0], fp) == EOF) return __FAIL; else return mkvoid; else return __FAIL; } /* C-style formatted I/O: *************************************************/ #define F_SZ 1024 static int f_err, f_var_wd, f_var_prec; static int f_wd, f_prec; static char *f_ptr, f_str[F_SZ], f_format[F_SZ], f_flags[F_SZ], f_mod[F_SZ]; static char f_wd_str[F_SZ], f_prec_str[F_SZ]; static void f_init(char *format) { f_ptr = format; f_err = 0; } #define F_SZ_CHK(len) if (len>=F_SZ) { f_err = 1; return 0; } else /* scan printf format string */ static char f_parse_pf(void) { char c, *p, *q, *r; f_var_wd = f_var_prec = f_wd = f_prec = 0; for (p = strchr(f_ptr, '%'); p && p[1] == '%'; p = strchr(p+2, '%')) ; if (!p) { /* no more conversions, return the rest of the string */ F_SZ_CHK(strlen(f_ptr)) strcpy(f_str, f_ptr); *f_format = *f_flags = *f_mod = 0; f_ptr = f_ptr + strlen(f_ptr); return 0; } /* conversion starts at p, parse it */ F_SZ_CHK(p-f_ptr) strncpy(f_str, f_ptr, p-f_ptr); f_str[p-f_ptr] = 0; q = r = p+1; /* flags */ while (strchr("#0- +", *r)) r++; F_SZ_CHK(r-q) strncpy(f_flags, q, r-q); f_flags[r-q] = 0; q = r; /* field width */ if (*r == '*') { r++; f_var_wd = 1; *f_wd_str = 0; } else { while (isdigit(*r)) r++; F_SZ_CHK(r-q) strncpy(f_wd_str, q, r-q); f_wd_str[r-q] = 0; } if (*f_wd_str) f_wd = atoi(f_wd_str); q = r; /* precision */ if (*r == '.') { r++; if (*r == '*') { r++; f_var_prec = 1; *f_prec_str = 0; } else { while (isdigit(*r)) r++; F_SZ_CHK(r-q) strncpy(f_prec_str, q, r-q); f_prec_str[r-q] = 0; } if (*f_prec_str) f_prec = atoi(f_prec_str); } q = r; /* length modifier */ while (strchr("hl", *r)) r++; F_SZ_CHK(r-q) strncpy(f_mod, q, r-q); f_mod[r-q] = 0; q = r; /* conversion specifier */ c = *(r++); F_SZ_CHK(r-p) strncpy(f_format, p, r-p); f_format[r-p] = 0; f_ptr = r; return c; } /* scan scanf format string */ static char f_parse_sf(void) { char c, *p, *q, *r; f_wd = -1; for (p = strchr(f_ptr, '%'); p && p[1] == '%'; p = strchr(p+2, '%')) ; if (!p) { /* no more conversions, return the rest of the string */ F_SZ_CHK(strlen(f_ptr)) strcpy(f_str, f_ptr); *f_format = *f_flags = *f_mod = 0; f_ptr = f_ptr + strlen(f_ptr); return 0; } /* conversion starts at p, parse it */ F_SZ_CHK(p-f_ptr) strncpy(f_str, f_ptr, p-f_ptr); f_str[p-f_ptr] = 0; q = r = p+1; /* flags */ while (strchr("*", *r)) r++; F_SZ_CHK(r-q) strncpy(f_flags, q, r-q); f_flags[r-q] = 0; q = r; /* field width */ while (isdigit(*r)) r++; F_SZ_CHK(r-q) strncpy(f_wd_str, q, r-q); f_wd_str[r-q] = 0; if (*f_wd_str) f_wd = atoi(f_wd_str); q = r; /* length modifier */ while (strchr("hl", *r)) r++; F_SZ_CHK(r-q) strncpy(f_mod, q, r-q); f_mod[r-q] = 0; q = r; /* conversion specifier */ c = *(r++); if (c == '[') { /* character class */ if (*r == ']') r++; else if (r[0] == '^' && r[1] == ']') r += 2; while (*r && *r != ']') r++; if (*r == ']') r++; else { f_err = 1; c = 0; } } F_SZ_CHK(r-p) strncpy(f_format, p, r-p); f_format[r-p] = 0; f_ptr = r; return c; } static int coerce_int(expr x, unsigned long *u) { mpz_t z; double d; if (ismpz(x, z)) { if (mpz_sgn(z) != 0) *u = z->_mp_d[0]; else *u = 0; if (mpz_sgn(z) < 0) *u = ~(*u)+1U; return 1; } else if (isfloat(x, &d)) { *u = (unsigned long)((d>=0.0)?d:(-d)); if (d < 0) *u = ~(*u)+1U; return 1; } else return 0; } static int coerce_float(expr x, double *d) { if (isfloat(x, d) || ismpz_float(x, d)) return 1; else return 0; } #define CALL_FPRINTF(fp,val) \ ((f_var_wd && f_var_prec)? \ fprintf(fp, f_format, (int)wdval, (int)precval, val): \ (f_var_wd)? \ fprintf(fp, f_format, (int)wdval, val): \ (f_var_prec)? \ fprintf(fp, f_format, (int)precval, val): \ fprintf(fp, f_format, val)) FUNCTION(clib,fprintf,argc,argv) { expr x, *xs; int i, n, ret; char f, *format; FILE *fp; long intval, wdval, precval; unsigned long uintval; double dblval; char *strval; if (argc != 3 || !isfile(argv[0], &fp) || !isstr(argv[1], &format)) return __FAIL; lock_format(); if (!istuple(argv[2], &n, &xs)) { x = argv[2]; xs = &x; n = 1; } /* parse the format string and check arguments */ f_init(format); i = 0; while ((f = f_parse_pf())) { if (*f_mod) if (strcmp(f_mod, "l") && strcmp(f_mod, "h") || !strchr("diouxX", f)) { unlock_format(); return __FAIL; } if (f_var_wd) if ((i >= n || !coerce_int(xs[i], &wdval))) { unlock_format(); return __FAIL; } else i++; if (f_var_prec) if ((i >= n || !coerce_int(xs[i], &precval))) { unlock_format(); return __FAIL; } else i++; switch (f) { case 'd': case 'i': if (i >= n || !coerce_int(xs[i], &intval)) { unlock_format(); return __FAIL; } else i++; break; case 'o': case 'u': case 'x': case 'X': if (i >= n || !coerce_int(xs[i], &uintval)) { unlock_format(); return __FAIL; } else i++; break; case 'e': case 'E': case 'f': case 'g': case 'G': if (i >= n || !coerce_float(xs[i], &dblval)) { unlock_format(); return __FAIL; } else i++; break; case 'c': if (i >= n || !isstr(xs[i], &strval) || !strval[0] || strval[1]) { unlock_format(); return __FAIL; } else i++; break; case 's': if (i >= n || !isstr(xs[i], &strval)) { unlock_format(); return __FAIL; } else i++; break; default: unlock_format(); return __FAIL; } } if (f_err) { unlock_format(); return __FAIL; } /* print */ f_init(format); i = 0; while ((f = f_parse_pf())) { if (fprintf(fp, f_str) < 0) goto errexit; if (f_var_wd) coerce_int(xs[i++], &wdval); if (f_var_prec) coerce_int(xs[i++], &precval); ret = 0; switch (f) { case 'd': case 'i': coerce_int(xs[i++], &intval); if (*f_mod == 'l') ret = CALL_FPRINTF(fp, intval); else if (*f_mod == 'h') ret = CALL_FPRINTF(fp, (short)intval); else ret = CALL_FPRINTF(fp, (int)intval); break; case 'o': case 'u': case 'x': case 'X': coerce_int(xs[i++], &uintval); if (*f_mod == 'l') ret = CALL_FPRINTF(fp, uintval); else if (*f_mod == 'h') ret = CALL_FPRINTF(fp, (unsigned short)uintval); else ret = CALL_FPRINTF(fp, (unsigned)uintval); break; case 'e': case 'E': case 'f': case 'g': case 'G': coerce_float(xs[i++], &dblval); ret = CALL_FPRINTF(fp, dblval); break; case 'c': isstr(xs[i++], &strval); ret = CALL_FPRINTF(fp, (int)*strval); break; case 's': isstr(xs[i++], &strval); ret = CALL_FPRINTF(fp, strval); break; } if (ret < 0) goto errexit; } if (fprintf(fp, f_str) < 0) goto errexit; f_init(NULL); unlock_format(); return mkvoid; errexit: f_init(NULL); unlock_format(); return __FAIL; } FUNCTION(clib,printf,argc,argv) { char *format; if (argc == 2 && isstr(argv[0], &format)) { expr output = eval(mksym(sym(OUTPUT))); if (output) { expr argv1[3] = { output, argv[0], argv[1] }; expr ret = FUNCALL(clib, fprintf, 3, argv1); dispose(output); return ret; } else return __FAIL; } else return __FAIL; } static char *buf = NULL, *bufptr = NULL; static long alloc = 0, leng = 0; static int addbuf(long newleng) { if (!buf) alloc = leng = 0; else leng = strlen(buf); if (leng+newleng+1 <= 0) { if (!buf) bufptr = NULL; return 0; } while (leng+newleng >= alloc) { if (buf) { char *newbuf; if (alloc+BUFSZ <= 0 || !(newbuf = realloc(buf, alloc+BUFSZ))) { bufptr = buf+leng; return 0; } else { buf = newbuf; alloc += BUFSZ; } } else { if (!(buf = malloc(BUFSZ))) { bufptr = NULL; return 0; } else { alloc = BUFSZ; *buf = 0; } } } bufptr = buf+leng; return 1; } #define CALL_SPRINTF(s,val) \ ((f_var_wd && f_var_prec)? \ sprintf(s, f_format, (int)wdval, (int)precval, val): \ (f_var_wd)? \ sprintf(s, f_format, (int)wdval, val): \ (f_var_prec)? \ sprintf(s, f_format, (int)precval, val): \ sprintf(s, f_format, val)) FUNCTION(clib,sprintf,argc,argv) { expr x, *xs; int i, n, ret; long sz, k, l; char f, *format, *s; long intval, wdval, precval; unsigned long uintval; double dblval; char *strval; if (argc != 2 || !isstr(argv[0], &format)) return __FAIL; lock_format(); if (!istuple(argv[1], &n, &xs)) { x = argv[1]; xs = &x; n = 1; } /* parse the format string and check arguments, guestimate needed buffer size */ f_init(format); i = 0; sz = BUFSZ; while ((f = f_parse_pf())) { if (*f_mod) if (strcmp(f_mod, "l") && strcmp(f_mod, "h") || !strchr("diouxX", f)) { unlock_format(); return __FAIL; } if (f_var_wd) if ((i >= n || !coerce_int(xs[i], &wdval))) { unlock_format(); return __FAIL; } else { f_wd = wdval; i++; } if (f_var_prec) if ((i >= n || !coerce_int(xs[i], &precval))) { unlock_format(); return __FAIL; } else { f_prec = precval; i++; } if (f_wd < 0) f_wd = -f_wd; if (f_prec < 0) f_prec = 0; l = f_wd+f_prec; switch (f) { case 'd': case 'i': if (i >= n || !coerce_int(xs[i], &intval)) { unlock_format(); return __FAIL; } else i++; if (BUFSZ+l > sz) sz = BUFSZ+l; break; case 'o': case 'u': case 'x': case 'X': if (i >= n || !coerce_int(xs[i], &uintval)) { unlock_format(); return __FAIL; } else i++; if (BUFSZ+l > sz) sz = BUFSZ+l; break; case 'e': case 'E': case 'f': case 'g': case 'G': if (i >= n || !coerce_float(xs[i], &dblval)) { unlock_format(); return __FAIL; } else i++; if (f == 'f') { k = log10(abs(dblval)+1)+2; if (BUFSZ+l+k > sz) sz = BUFSZ+l+k; } else { if (BUFSZ+l > sz) sz = BUFSZ+l; } break; case 'c': if (i >= n || !isstr(xs[i], &strval) || !strval[0] || strval[1]) { unlock_format(); return __FAIL; } else i++; if (l+1 > sz) sz = l+1; break; case 's': if (i >= n || !isstr(xs[i], &strval)) { unlock_format(); return __FAIL; } else i++; k = strlen(strval); if (k+l > sz) sz = k+l; break; default: unlock_format(); return __FAIL; } } if (f_err) { unlock_format(); return __FAIL; } /* allocate buffer */ if (sz <= 0 || !(s = malloc(sz+1))) { unlock_format(); return __ERROR; } buf = NULL; /* print */ f_init(format); i = 0; while ((f = f_parse_pf())) { if (!addbuf(strlen(f_str))) goto errexit2; if (sprintf(bufptr, f_str) < 0) goto errexit; bufptr += strlen(bufptr); if (f_var_wd) coerce_int(xs[i++], &wdval); if (f_var_prec) coerce_int(xs[i++], &precval); *s = 0; switch (f) { case 'd': case 'i': coerce_int(xs[i++], &intval); if (*f_mod == 'l') ret = CALL_SPRINTF(s, intval); else if (*f_mod == 'h') ret = CALL_SPRINTF(s, (short)intval); else ret = CALL_SPRINTF(s, (int)intval); break; case 'o': case 'u': case 'x': case 'X': coerce_int(xs[i++], &uintval); if (*f_mod == 'l') ret = CALL_SPRINTF(s, uintval); else if (*f_mod == 'h') ret = CALL_SPRINTF(s, (unsigned short)uintval); else ret = CALL_SPRINTF(s, (unsigned)uintval); break; case 'e': case 'E': case 'f': case 'g': case 'G': coerce_float(xs[i++], &dblval); ret = CALL_SPRINTF(s, dblval); break; case 'c': isstr(xs[i++], &strval); ret = CALL_SPRINTF(s, (int)*strval); break; case 's': isstr(xs[i++], &strval); ret = CALL_SPRINTF(s, strval); break; } if (ret < 0) goto errexit; if (!addbuf(strlen(s))) goto errexit2; strcpy(bufptr, s); bufptr += strlen(bufptr); } if (!addbuf(strlen(f_str))) goto errexit2; if (sprintf(bufptr, f_str) < 0) goto errexit; bufptr += strlen(bufptr); f_init(NULL); unlock_format(); free(s); buf = realloc(buf, strlen(buf)+1); return mkstr(buf); errexit: f_init(NULL); unlock_format(); if (buf) free(buf); free(s); return __FAIL; errexit2: f_init(NULL); unlock_format(); if (buf) free(buf); free(s); return __ERROR; } #define DFLT_STRLEN 10240 /* scanning literals is a bit tricky, since there is no obvious sign indicating that the match has failed -- we have to check for non-ws chars in the template */ static int fscan_literal(FILE *fp, long *ncount, char *template) { long count = -1; short empty = 1; char *p; for (p = template; *p; p++) if (!isspace(*p)) { empty = 0; break; } if (strlen(template) >= F_SZ-3) return 0; #ifndef WIN32 strcat(template, "%ln"); #else /* WIN32 */ strcat(template, "%n"); #endif /* WIN32 */ if (fscanf(fp, template, &count) < 0) return 0; if (count < 0) return 0; if (count == 0 && !empty) return 0; *ncount += count; return 1; } FUNCTION(clib,fscanf,argc,argv) { expr *xs, x; int i, n, ret; long count, ncount = 0; char f, *format; FILE *fp; short shortval; unsigned short ushortval; int intval; unsigned uintval; long longval; unsigned long ulongval; float fltval; double dblval; char *strval; if (argc != 2 || !isfile(argv[0], &fp) || !isstr(argv[1], &format)) return __FAIL; release_lock(); if (fp == stdin) acquire_tty(); lock_format(); f_init(format); i = 0; while ((f = f_parse_sf())) { if (*f_flags) if (strcmp(f_flags, "*")) { unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); return __FAIL; } if (*f_mod) if (strcmp(f_mod, "l") && strcmp(f_mod, "h") || *f_mod == 'l' && !strchr("ndiouxXeEfgG", f) || *f_mod == 'h' && !strchr("ndiouxX", f)) { unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); return __FAIL; } switch (f) { case 'n': case 'd': case 'i': case 'o': case 'u': case 'x': case 'X': case 'e': case 'E': case 'f': case 'g': case 'G': case 'c': case 's': case '[': if (!*f_flags) i++; break; default: unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); return __FAIL; } } if (f_err) { unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); return __FAIL; } n = i; if (n == 0) xs = NULL; else if (!(xs = malloc(n*sizeof(expr)))) { unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); return __ERROR; } f_init(format); i = 0; while ((f = f_parse_sf())) { if (!fscan_literal(fp, &ncount, f_str)) goto errexit; if (strlen(f_format) >= F_SZ-3) goto errexit; #ifndef WIN32 strcat(f_format, "%ln"); #else /* WIN32 */ strcat(f_format, "%n"); #endif /* WIN32 */ if (*f_flags) { count = -1; fscanf(fp, f_format, &count); if (count < 0) goto errexit; ncount += count; continue; } switch (f) { case 'n': if (*f_mod == 'h') { shortval = ncount; ret = (xs[i] = mkint(shortval)) != NULL; } else if (*f_mod == 'h') { longval = ncount; ret = (xs[i] = mkint(longval)) != NULL; } else { intval = ncount; ret = (xs[i] = mkint(intval)) != NULL; } if (!ret) goto errexit2; else i++; count = 0; break; case 'd': case 'i': count = -1; if (*f_mod == 'h') ret = !(fscanf(fp, f_format, &shortval, &count) > 0 && count >= 0)?1: !(xs[i] = mkint(shortval))?-1:0; else if (*f_mod == 'l') ret = !(fscanf(fp, f_format, &longval, &count) > 0 && count >= 0)?1: !(xs[i] = mkint(longval))?-1:0; else ret = !(fscanf(fp, f_format, &intval, &count) > 0 && count >= 0)?1: !(xs[i] = mkint(intval))?-1:0; if (ret == -1) goto errexit2; else if (ret == 1) goto errexit; else i++; break; case 'o': case 'u': case 'x': case 'X': count = -1; if (*f_mod == 'h') ret = !(fscanf(fp, f_format, &ushortval, &count) > 0 && count >= 0)?1: !(xs[i] = mkuint(ushortval))?-1:0; else if (*f_mod == 'l') ret = !(fscanf(fp, f_format, &ulongval, &count) > 0 && count >= 0)?1: !(xs[i] = mkuint(ulongval))?-1:0; else ret = !(fscanf(fp, f_format, &uintval, &count) > 0 && count >= 0)?1: !(xs[i] = mkuint(uintval))?-1:0; if (ret == -1) goto errexit2; else if (ret == 1) goto errexit; else i++; break; case 'e': case 'E': case 'f': case 'g': case 'G': count = -1; if (*f_mod == 'l') ret = !(fscanf(fp, f_format, &dblval, &count) > 0 && count >= 0)?1: !(xs[i] = mkfloat(dblval))?-1:0; else ret = !(fscanf(fp, f_format, &fltval, &count) > 0 && count >= 0)?1: !(xs[i] = mkfloat(fltval))?-1:0; if (ret == -1) goto errexit2; else if (ret == 1) goto errexit; else i++; break; case 'c': count = -1; if (f_wd <= 0) f_wd = 1; if (!(strval = malloc(f_wd+1))) goto errexit2; *strval = 0; if (fscanf(fp, f_format, strval, &count) <= 0 || count < 0) { free(strval); goto errexit; } else { strval[f_wd] = 0; strval = realloc(strval, strlen(strval)+1); if (!(xs[i] = mkstr(strval))) goto errexit2; else i++; } break; case 's': case '[': count = -1; if (f_wd <= 0) { char new_format[F_SZ]; f_wd = DFLT_STRLEN; if (strlen(f_format)+10 > F_SZ) goto errexit; sprintf(new_format, "%%%d%s", f_wd, f_format+1); strcpy(f_format, new_format); } if (!(strval = malloc(f_wd+1))) goto errexit2; *strval = 0; if (fscanf(fp, f_format, strval, &count) <= 0 || count < 0) { free(strval); goto errexit; } else { strval = realloc(strval, strlen(strval)+1); if (!(xs[i] = mkstr(strval))) goto errexit2; else i++; } break; } ncount += count; } if (!fscan_literal(fp, &ncount, f_str)) goto errexit; unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); if (n == 0) return mkvoid; else if (n == 1) { x = xs[0]; free(xs); return x; } else return mktuplev(n, xs); errexit: unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); while (i > 0) dispose(xs[--i]); if (n > 0) free(xs); return __FAIL; errexit2: unlock_format(); if (fp == stdin) release_tty(); acquire_lock(); while (i > 0) dispose(xs[--i]); if (n > 0) free(xs); return __ERROR; } FUNCTION(clib,scanf,argc,argv) { char *format; if (argc == 1 && isstr(argv[0], &format)) { expr input = eval(mksym(sym(INPUT))); if (input) { expr argv1[2] = { input, argv[0] }; expr ret = FUNCALL(clib, fscanf, 2, argv1); dispose(input); return ret; } else return __FAIL; } else return __FAIL; } static int sscan_literal(char **s, long *ncount, char *template) { long count = -1; int empty = 1; char *p; for (p = template; *p; p++) if (!isspace(*p)) { empty = 0; break; } if (strlen(template) >= F_SZ-3) return 0; #ifndef WIN32 strcat(template, "%ln"); #else /* WIN32 */ /* work around a bug in the msvc sscanf function -- it doesn't recognize %ln */ strcat(template, "%n"); #endif /* WIN32 */ if (sscanf(*s, template, &count) < 0) return 0; if (count < 0) return 0; if (count == 0 && !empty) return 0; *s += count; *ncount += count; return 1; } FUNCTION(clib,sscanf,argc,argv) { expr *xs, x; int i, n, ret; long count, ncount = 0; char f, *format; char *s; short shortval; unsigned short ushortval; int intval; unsigned uintval; long longval; unsigned long ulongval; float fltval; double dblval; char *strval; if (argc != 2 || !isstr(argv[0], &s) || !isstr(argv[1], &format)) return __FAIL; release_lock(); lock_format(); f_init(format); i = 0; while ((f = f_parse_sf())) { if (*f_flags) if (strcmp(f_flags, "*")) { unlock_format(); acquire_lock(); return __FAIL; } if (*f_mod) if (strcmp(f_mod, "l") && strcmp(f_mod, "h") || *f_mod == 'l' && !strchr("ndiouxXeEfgG", f) || *f_mod == 'h' && !strchr("ndiouxX", f)) { unlock_format(); acquire_lock(); return __FAIL; } switch (f) { case 'n': case 'd': case 'i': case 'o': case 'u': case 'x': case 'X': case 'e': case 'E': case 'f': case 'g': case 'G': case 'c': case 's': case '[': if (!*f_flags) i++; break; default: unlock_format(); acquire_lock(); return __FAIL; } } if (f_err) { unlock_format(); acquire_lock(); return __FAIL; } n = i; if (n == 0) xs = NULL; else if (!(xs = malloc(n*sizeof(expr)))) { unlock_format(); acquire_lock(); return __ERROR; } f_init(format); i = 0; while ((f = f_parse_sf())) { if (!sscan_literal(&s, &ncount, f_str)) goto errexit; if (strlen(f_format) >= F_SZ-3) goto errexit; #ifndef WIN32 strcat(f_format, "%ln"); #else /* WIN32 */ strcat(f_format, "%n"); #endif /* WIN32 */ if (*f_flags) { count = -1; sscanf(s, f_format, &count); if (count < 0) goto errexit; s += count; ncount += count; continue; } switch (f) { case 'n': if (*f_mod == 'h') { shortval = ncount; ret = (xs[i] = mkint(shortval)) != NULL; } else if (*f_mod == 'h') { longval = ncount; ret = (xs[i] = mkint(longval)) != NULL; } else { intval = ncount; ret = (xs[i] = mkint(intval)) != NULL; } if (!ret) goto errexit2; else i++; count = 0; break; case 'd': case 'i': count = -1; if (*f_mod == 'h') ret = !(sscanf(s, f_format, &shortval, &count) > 0 && count >= 0)?1: !(xs[i] = mkint(shortval))?-1:0; else if (*f_mod == 'l') ret = !(sscanf(s, f_format, &longval, &count) > 0 && count >= 0)?1: !(xs[i] = mkint(longval))?-1:0; else ret = !(sscanf(s, f_format, &intval, &count) > 0 && count >= 0)?1: !(xs[i] = mkint(intval))?-1:0; if (ret == -1) goto errexit2; else if (ret == 1) goto errexit; else i++; break; case 'o': case 'u': case 'x': case 'X': count = -1; if (*f_mod == 'h') ret = !(sscanf(s, f_format, &ushortval, &count) > 0 && count >= 0)?1: !(xs[i] = mkuint(ushortval))?-1:0; else if (*f_mod == 'l') ret = !(sscanf(s, f_format, &ulongval, &count) > 0 && count >= 0)?1: !(xs[i] = mkuint(ulongval))?-1:0; else ret = !(sscanf(s, f_format, &uintval, &count) > 0 && count >= 0)?1: !(xs[i] = mkuint(uintval))?-1:0; if (ret == -1) goto errexit2; else if (ret == 1) goto errexit; else i++; break; case 'e': case 'E': case 'f': case 'g': case 'G': count = -1; if (*f_mod == 'l') ret = !(sscanf(s, f_format, &dblval, &count) > 0 && count >= 0)?1: !(xs[i] = mkfloat(dblval))?-1:0; else ret = !(sscanf(s, f_format, &fltval, &count) > 0 && count >= 0)?1: !(xs[i] = mkfloat(fltval))?-1:0; if (ret == -1) goto errexit2; else if (ret == 1) goto errexit; else i++; break; case 'c': count = -1; if (f_wd == -1) f_wd = 1; if (f_wd > strlen(s)) goto errexit; if (!(strval = malloc(f_wd+1))) goto errexit2; *strval = 0; if (sscanf(s, f_format, strval, &count) <= 0 || count < 0) { free(strval); goto errexit; } else { strval[f_wd] = 0; strval = realloc(strval, strlen(strval)+1); if (!(xs[i] = mkstr(strval))) goto errexit2; else i++; } break; case 's': case '[': count = -1; if (f_wd == -1) { char new_format[F_SZ]; f_wd = DFLT_STRLEN; if (strlen(f_format)+10 > F_SZ) goto errexit; sprintf(new_format, "%%%d%s", f_wd, f_format+1); strcpy(f_format, new_format); } if (!(strval = malloc(f_wd+1))) goto errexit2; *strval = 0; if (sscanf(s, f_format, strval, &count) <= 0 || count < 0) { free(strval); goto errexit; } else { strval = realloc(strval, strlen(strval)+1); if (!(xs[i] = mkstr(strval))) goto errexit2; else i++; } break; default: goto errexit; } s += count; ncount += count; } if (!sscan_literal(&s, &ncount, f_str)) goto errexit; unlock_format(); acquire_lock(); if (n == 0) return mkvoid; else if (n == 1) { x = xs[0]; free(xs); return x; } else return mktuplev(n, xs); errexit: unlock_format(); acquire_lock(); while (i > 0) dispose(xs[--i]); if (n > 0) free(xs); return __FAIL; errexit2: unlock_format(); acquire_lock(); while (i > 0) dispose(xs[--i]); if (n > 0) free(xs); return __ERROR; } /* low-level I/O ************************************************************/ FUNCTION(clib,open,argc,argv) { char *name; long flags, mode, fd; if (argc != 3 || !isstr(argv[0], &name) || !isint(argv[1], &flags) || !isint(argv[2], &mode)) return __FAIL; fd = open(name, flags, mode); if (fd < 0) return __FAIL; else return mkint(fd); } FUNCTION(clib,close,argc,argv) { long fd; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; if (close(fd)) return __FAIL; else return mkvoid; } FUNCTION(clib,dup,argc,argv) { #ifdef HAVE_DUP long fd; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; fd = dup(fd); if (fd < 0) return __FAIL; else return mkint(fd); #else return __FAIL; #endif } FUNCTION(clib,dup2,argc,argv) { #ifdef HAVE_DUP2 long fd, fd2; if (argc != 2 || !isint(argv[0], &fd) || !isint(argv[1], &fd2)) return __FAIL; fd = dup2(fd, fd2); if (fd < 0) return __FAIL; else return mkint(fd); #else return __FAIL; #endif } FUNCTION(clib,pipe,argc,argv) { #ifdef HAVE_PIPE int fd[2]; if (argc != 0) return __FAIL; #ifdef WIN32 if (_pipe(fd, 256, O_BINARY)) #else if (pipe(fd)) #endif return __FAIL; else return mktuplel(2, mkint(fd[0]), mkint(fd[1])); #else return __FAIL; #endif } static expr statres(struct stat *buf) { expr *st, x; if (!(st = malloc(11*sizeof(expr)))) return __ERROR; /* FIXME: all types are assumed to fit into a 4 byte value; this may not be true for some (dev_t, maybe others?) */ st[0] = mkuint(buf->st_dev); st[1] = mkuint(buf->st_ino); st[2] = mkuint(buf->st_mode); st[3] = mkuint(buf->st_nlink); st[4] = mkuint(buf->st_uid); st[5] = mkuint(buf->st_gid); #ifdef HAVE_ST_RDEV st[6] = mkuint(buf->st_rdev); #else st[6] = mkuint(0); #endif st[7] = mkint(buf->st_size); st[8] = mkint(buf->st_atime); st[9] = mkint(buf->st_mtime); st[10] = mkint(buf->st_ctime); x = mktuplev(11, st); if (x) return x; else return __ERROR; } FUNCTION(clib,fstat,argc,argv) { #ifdef HAVE_FSTAT long fd; struct stat buf; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; if (fstat(fd, &buf)) return __FAIL; else return statres(&buf); #else return __FAIL; #endif } FUNCTION(clib,fchdir,argc,argv) { #ifdef HAVE_FCHDIR long fd; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; if (fchdir(fd)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,fchmod,argc,argv) { #ifdef HAVE_FCHMOD long fd, mode; if (argc != 2 || !isint(argv[0], &fd) || !isint(argv[1], &mode)) return __FAIL; if (fchmod(fd, mode)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,fchown,argc,argv) { #ifdef HAVE_FCHOWN long fd, uid, gid; if (argc != 3 || !isint(argv[0], &fd) || !isint(argv[1], &uid) || !isint(argv[2], &gid)) return __FAIL; if (fchown(fd, uid, gid)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,ftruncate,argc,argv) { #ifdef HAVE_FTRUNCATE long fd, len; if (argc != 2 || !isint(argv[0], &fd) || !isint(argv[1], &len)) return __FAIL; if (ftruncate(fd, len)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,fsync,argc,argv) { #ifdef HAVE_FSYNC long fd; int res; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; release_lock(); res = fsync(fd); acquire_lock(); if (res) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,fdatasync,argc,argv) { #ifdef HAVE_FDATASYNC long fd; int res; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; release_lock(); res = fdatasync(fd); acquire_lock(); if (res) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,bread,argc,argv) { FILE *fp; long fd, count, res; void *v = NULL, *v1; if (argc != 2 || !isint(argv[1], &count) || count < 0) return __FAIL; if (isint(argv[0], &fd)) { if (count && !(v = malloc(count))) return __ERROR; release_lock(); res = read(fd, v, count); acquire_lock(); } else if (isfile(argv[0], &fp)) { if (count && !(v = malloc(count))) return __ERROR; release_lock(); res = fread(v, 1, count, fp); acquire_lock(); if (res == 0 && ferror(fp)) res = -1; } else return __FAIL; if (res < 0) { free(v); return __FAIL; } else { if (res != count) if (res == 0) { free(v); v = NULL; } else if ((v1 = realloc(v, res))) v = v1; return mkbstr(res, v); } } FUNCTION(clib,bwrite,argc,argv) { FILE *fp; long fd, res; bstr_t *m; if (argc != 2 || !isobj(argv[1], type(ByteStr), (void**)&m)) return __FAIL; if (isint(argv[0], &fd)) { if (!m->v) return mkint(0); else { release_lock(); res = write(fd, m->v, m->size); acquire_lock(); } } else if (isfile(argv[0], &fp)) { if (!m->v) return mkint(0); else { release_lock(); res = fwrite(m->v, 1, m->size, fp); acquire_lock(); } if (res == 0 && ferror(fp)) res = -1; } else return __FAIL; if (res < 0) return __FAIL; else return mkint(res); } FUNCTION(clib,lseek,argc,argv) { long fd, pos, whence; if (argc == 3 && isint(argv[0], &fd) && isint(argv[1], &pos) && isint(argv[2], &whence)) { off_t res = lseek(fd, pos, whence); if (res == (off_t)-1) return __FAIL; else return mkint((long)res); } else return __FAIL; } FUNCTION(clib,fcntl,argc,argv) { #ifdef HAVE_FCNTL_H long fd, cmd, arg, flags, type, pos, len, whence = SEEK_SET; struct flock lock; int n; expr *xs; if (argc != 3 || !isint(argv[0], &fd) || !isint(argv[1], &cmd)) return __FAIL; switch (cmd) { case F_DUPFD: if (!isint(argv[2], &arg)) return __FAIL; fd = fcntl(fd, cmd, arg); if (fd >= 0) return mkint(fd); else return __FAIL; case F_GETFD: case F_GETFL: flags = fcntl(fd, cmd); if (flags >= 0) return mkint(flags); else return __FAIL; case F_SETFD: case F_SETFL: if (!isint(argv[2], &flags)) return __FAIL; if (!fcntl(fd, cmd, flags)) return mkvoid; else return __FAIL; case F_GETLK: case F_SETLK: case F_SETLKW: if (!istuple(argv[2], &n, &xs) || n < 3 || n > 4 || !isint(xs[0], &type) || !isint(xs[1], &pos) || !isint(xs[2], &len) || n == 4 && !isint(xs[3], &whence)) return __FAIL; lock.l_type = type; lock.l_whence = whence; lock.l_start = pos; lock.l_len = len; lock.l_pid = getpid(); if (!fcntl(fd, cmd, &lock)) if (cmd==F_GETLK) if (n == 3) return mktuplel(4, mkint(lock.l_type), mkint(lock.l_start), mkint(lock.l_len), mkint(lock.l_pid)); else return mktuplel(5, mkint(lock.l_type), mkint(lock.l_start), mkint(lock.l_len), mkint(lock.l_whence), mkint(lock.l_pid)); else return mkvoid; else return __FAIL; default: return __FAIL; } #else return __FAIL; #endif } FUNCTION(clib,isatty,argc,argv) { long fd; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; if (isatty(fd)) return mktrue; else return mkfalse; } FUNCTION(clib,ttyname,argc,argv) { #ifdef HAVE_TTYNAME long fd; char *name; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; name = ttyname(fd); if (name) return mkstr(strdup(name)); else return __FAIL; #else return __FAIL; #endif } FUNCTION(clib,ctermid,argc,argv) { #ifdef HAVE_CTERMID char *name; if (argc != 0) return __FAIL; name = ctermid(NULL); if (name) return mkstr(strdup(name)); else return __FAIL; #else return __FAIL; #endif } #if (!defined(HAVE_OPENPTY) || !defined(HAVE_FORKPTY)) && defined(HAVE_GRANTPT) && !defined(HAVE_GETPT) static int getpt(void) { return open("/dev/ptmx", O_RDWR); } #endif #if !defined(HAVE_OPENPTY) && defined(HAVE_GRANTPT) static int open_pty(int *amaster, int *aslave) { int master, slave; char *name; master = getpt(); if (master < 0) return -1; if (grantpt(master) < 0 || unlockpt(master) < 0) goto close_master; name = ptsname (master); if (name == NULL) goto close_master; slave = open(name, O_RDWR); if (slave == -1) goto close_master; if (isastream(slave)) { if (ioctl(slave, I_PUSH, "ptem") < 0 || ioctl(slave, I_PUSH, "ldterm") < 0) goto close_slave; } *amaster = master; *aslave = slave; return 0; close_slave: close(slave); close_master: close(master); return -1; } #endif #if !defined(HAVE_FORKPTY) && defined(HAVE_GRANTPT) static int fork_pty(int *amaster) { int master, slave, pid; char *name; if ((master = getpt()) < 0) return -1; if (grantpt(master) < 0 || unlockpt(master) < 0) goto close_master; name = ptsname (master); if (name == NULL) goto close_master; if ((pid = fork()) < 0) goto close_master; if (pid == 0) { if (setsid() < 0) exit(1); /* under SVR3 the following open() will acquire the controlling terminal */ if ((slave = open(name, O_RDWR)) == -1) exit(1); if (isastream(slave)) { if (ioctl(slave, I_PUSH, "ptem") < 0 || ioctl(slave, I_PUSH, "ldterm") < 0) exit(1); } close(master); if (dup2(slave, STDIN_FILENO) != STDIN_FILENO || dup2(slave, STDOUT_FILENO) != STDOUT_FILENO || dup2(slave, STDERR_FILENO) != STDERR_FILENO) exit(1); if (slave > STDERR_FILENO) close(slave); *amaster = master; return 0; } else { *amaster = master; return pid; } close_slave: close(slave); close_master: close(master); return -1; } #endif FUNCTION(clib,openpty,argc,argv) { #if defined(HAVE_OPENPTY) || defined(HAVE_GRANTPT) int master, slave; if (argc != 0 || #ifdef HAVE_OPENPTY openpty(&master, &slave, NULL, NULL, NULL) #else open_pty(&master, &slave) #endif ) return __FAIL; else return mktuplel(2, mkint(master), mkint(slave)); #else return __FAIL; #endif } FUNCTION(clib,forkpty,argc,argv) { #if defined(HAVE_FORKPTY) || defined(HAVE_GRANTPT) int pid, master; if (argc != 0 || (pid = #ifdef HAVE_FORKPTY forkpty(&master, NULL, NULL, NULL) #else fork_pty(&master) #endif ) < 0) return __FAIL; else return mktuplel(2, mkint(pid), mkint(master)); #else return __FAIL; #endif } /* termios interface ********************************************************/ #ifdef HAVE_TERMIOS_H static expr mkcharlist(cc_t *cc) { int i; expr *xv = malloc(NCCS*sizeof(expr)); if (!xv) return NULL; for (i = 0; i < NCCS; i++) { if (!(xv[i] = mkint((long)cc[i]))) { while (i > 0) dispose(xv[--i]); free(xv); return NULL; } } return mklistv(NCCS, xv); } static expr decode_termios_val(struct termios *attr) { speed_t ispeed = cfgetispeed(attr), ospeed = cfgetospeed(attr); expr x = mktuplel(7, mkint(attr->c_iflag), mkint(attr->c_oflag), mkint(attr->c_cflag), mkint(attr->c_lflag), mkint(ispeed), mkint(ospeed), mkcharlist(attr->c_cc)); if (x) return x; else return __ERROR; } static int ischarlist(expr v, cc_t *cc) { int n; expr x, hd, tl; long c; for (n = 0, x = v; iscons(x, &hd, &tl) && isint(hd, &c); x = tl) n++; if (!isnil(x) || n != NCCS) return 0; for (n = 0, x = v; iscons(x, &hd, &tl) && isint(hd, &c); x = tl) cc[n++] = (cc_t)c; return 1; } static struct termios *encode_termios_val(int fd, expr x) { static struct termios attr; int n; expr *xv; long iflag, oflag, cflag, lflag, ispeed, ospeed; /* to be safe, we first fill the structure with the current values, since an implementation might have more fields than those required by POSIX */ tcgetattr(fd, &attr); if (istuple(x, &n, &xv) && n == 7 && isint(xv[0], &iflag) && isint(xv[1], &oflag) && isint(xv[2], &cflag) && isint(xv[3], &lflag) && isint(xv[4], &ispeed) && isint(xv[5], &ospeed) && ischarlist(xv[6], attr.c_cc)) { attr.c_iflag = iflag; attr.c_oflag = oflag; attr.c_cflag = cflag; attr.c_lflag = lflag; cfsetispeed(&attr, ispeed); cfsetospeed(&attr, ospeed); return &attr; } else return NULL; } #endif FUNCTION(clib,tcgetattr,argc,argv) { #ifdef HAVE_TERMIOS_H struct termios attr; long fd; if (argc == 1 && isint(argv[0], &fd) && !tcgetattr(fd, &attr)) return decode_termios_val(&attr); else #endif return __FAIL; } FUNCTION(clib,tcsetattr,argc,argv) { #ifdef HAVE_TERMIOS_H struct termios *attr; long fd, when; if (argc == 3 && isint(argv[0], &fd) && isint(argv[1], &when) && (attr = encode_termios_val(fd, argv[2])) && !tcsetattr(fd, when, attr)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,tcsendbreak,argc,argv) { #ifdef HAVE_TERMIOS_H long fd, duration; if (argc == 2 && isint(argv[0], &fd) && isint(argv[1], &duration) && !tcsendbreak(fd, duration)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,tcdrain,argc,argv) { #ifdef HAVE_TERMIOS_H long fd; if (argc == 1 && isint(argv[0], &fd) && !tcdrain(fd)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,tcflush,argc,argv) { #ifdef HAVE_TERMIOS_H long fd, queue; if (argc == 2 && isint(argv[0], &fd) && isint(argv[1], &queue) && !tcflush(fd, queue)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,tcflow,argc,argv) { #ifdef HAVE_TERMIOS_H long fd, action; if (argc == 2 && isint(argv[0], &fd) && isint(argv[1], &action) && !tcflow(fd, action)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,tcgetpgrp,argc,argv) { #ifdef HAVE_TCGETPGRP long fd, pgrp; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; pgrp = tcgetpgrp(fd); if (pgrp < 0) return __FAIL; else return mkint(pgrp); #else return __FAIL; #endif } FUNCTION(clib,tcsetpgrp,argc,argv) { #ifdef HAVE_TCSETPGRP long fd, pgrp; if (argc != 2 || !isint(argv[0], &fd) || !isint(argv[1], &pgrp)) return __FAIL; if (tcsetpgrp(fd, pgrp)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } /* socket interface: ******************************************************/ FUNCTION(clib,socket,argc,argv) { #ifdef HAVE_SOCKET long domain, type, proto; int fd; if (argc != 3 || !isint(argv[0], &domain) || !isint(argv[1], &type) || !isint(argv[2], &proto)) return __FAIL; if ((fd = socket(domain, type, proto)) < 0) return __FAIL; else return mkint(fd); #else return __FAIL; #endif } FUNCTION(clib,socketpair,argc,argv) { #ifdef HAVE_SOCKETPAIR long domain, type, proto; int fd[2]; if (argc != 3 || !isint(argv[0], &domain) || !isint(argv[1], &type) || !isint(argv[2], &proto)) return __FAIL; if (socketpair(domain, type, proto, fd)) return __FAIL; else return mktuplel(2, mkint(fd[0]), mkint(fd[1])); #else return __FAIL; #endif } FUNCTION(clib,shutdown,argc,argv) { #ifdef HAVE_SHUTDOWN long fd, how; if (argc != 2 || !isint(argv[0], &fd) || !isint(argv[1], &how)) return __FAIL; if (shutdown(fd, how)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,closesocket,argc,argv) { #ifdef HAVE_BSD_SOCKETS long fd; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; #ifdef HAVE_CLOSESOCKET if (closesocket(fd)) #else if (close(fd)) #endif return __FAIL; else return mkvoid; #else return __FAIL; #endif } #ifdef HAVE_BSD_SOCKETS /* FIXME: is this large enough for any type of address? */ #define SOCKADDR_SIZE 1024 static int isaddr(expr x, long *domain, char **name, long *port, unsigned long *flowinfo, unsigned long *scopeid) { int n; expr *xv; #ifdef AF_LOCAL if (isstr(x, name)) { *domain = AF_LOCAL; return 1; } else #endif if (!istuple(x, &n, &xv)) return 0; else if (n == 2) if (isstr(xv[0], name) && isint(xv[1], port)) { *domain = AF_INET; return 1; } else return 0; #ifdef HAVE_IPV6 else if (n == 4) if (isstr(xv[0], name) && isint(xv[1], port) && isuint(xv[2], flowinfo) && isuint(xv[3], scopeid)) { *domain = AF_INET6; return 1; } else return 0; #endif else return 0; } static struct sockaddr* encode_addr(long domain, char *name, long port, unsigned long flowinfo, unsigned long scopeid, #ifdef AF_LOCAL struct sockaddr_un *sa_un, #endif struct sockaddr_in *sa_in, #ifdef HAVE_IPV6 struct sockaddr_in6 *sa_in6, #endif int *len) { int l = strlen(name); #ifdef AF_LOCAL if (domain == AF_LOCAL) { memset(sa_un, 0, sizeof(struct sockaddr_un)); sa_un->sun_family = AF_LOCAL; strncpy(sa_un->sun_path, name, sizeof(sa_un->sun_path)); if (l >= sizeof(sa_un->sun_path)) sa_un->sun_path[sizeof(sa_un->sun_path)-1] = 0; *len = sizeof(sa_un->sun_family) + strlen(sa_un->sun_path) + 1; return (struct sockaddr*)sa_un; } else #endif if (domain == AF_INET) { if (port < 0 || port > 0xffff) return NULL; memset(sa_in, 0, sizeof(struct sockaddr_in)); /* first check for numeric addresses in standard dot notation */ #ifdef HAVE_INET_ATON /* inet_aton is the recommended interface, but it only seems to be available on BSDish systems */ if (!inet_aton(name, &sa_in->sin_addr)) { #else /* otherwise we just employ inet_addr which should be available anyway */ if ((sa_in->sin_addr.s_addr = inet_addr(name)) == INADDR_NONE) { #endif /* if the host wasn't found that way, it's probably a symbolic name; query the host database for it */ struct hostent *h = gethostbyname(name); if (!h || h->h_addrtype != AF_INET) return NULL; memcpy(&sa_in->sin_addr, h->h_addr, sizeof(struct in_addr)); } sa_in->sin_family = AF_INET; sa_in->sin_port = htons((uint16_t)port); *len = sizeof(struct sockaddr_in); return (struct sockaddr*)sa_in; #ifdef HAVE_IPV6 } else if (domain == AF_INET6) { if (port < 0 || port > 0xffff) return NULL; memset(sa_in6, 0, sizeof(struct sockaddr_in6)); if (!inet_pton(AF_INET6, name, &sa_in6->sin6_addr)) { struct hostent *h = gethostbyname(name); if (!h || h->h_addrtype != AF_INET6) return NULL; memcpy(&sa_in6->sin6_addr, h->h_addr, sizeof(struct in6_addr)); } sa_in6->sin6_family = AF_INET6; sa_in6->sin6_port = htons((uint16_t)port); sa_in6->sin6_flowinfo = htonl((uint32_t)flowinfo); sa_in6->sin6_scope_id = htonl((uint32_t)scopeid); *len = sizeof(struct sockaddr_in6); return (struct sockaddr*)sa_in6; #endif } else return NULL; } static expr decode_addr(struct sockaddr *sa, int len) { #ifdef AF_LOCAL if (sa->sa_family == AF_LOCAL) { struct sockaddr_un *sa_un = (struct sockaddr_un*)sa; return mkstr(strdup(sa_un->sun_path)); } else #endif if (sa->sa_family == AF_INET) { struct sockaddr_in *sa_in = (struct sockaddr_in*)sa; char *name = inet_ntoa(sa_in->sin_addr); return mktuplel(2, mkstr(strdup(name)), mkuint((unsigned long)ntohs(sa_in->sin_port))); #ifdef HAVE_IPV6 } else if (sa->sa_family == AF_INET6) { struct sockaddr_in6 *sa_in6 = (struct sockaddr_in6*)sa; char buf[BUFSZ]; const char *name; name = inet_ntop(AF_INET6, &sa_in6->sin6_addr, buf, BUFSZ); if (name) return mktuplel(4, mkstr(strdup(name)), mkuint((unsigned long)ntohs(sa_in6->sin6_port)), mkuint((unsigned long)ntohl(sa_in6->sin6_flowinfo)), mkuint((unsigned long)ntohl(sa_in6->sin6_scope_id))); else return NULL; #endif } else return NULL; } #endif FUNCTION(clib,bind,argc,argv) { #ifdef HAVE_BIND long fd, domain, port; unsigned long flowinfo, scopeid; char *name; struct sockaddr *sa; #ifdef AF_LOCAL struct sockaddr_un sa_un; #endif struct sockaddr_in sa_in; #ifdef HAVE_IPV6 struct sockaddr_in6 sa_in6; #endif int len; if (argc != 2 || !isint(argv[0], &fd) || !isaddr(argv[1], &domain, &name, &port, &flowinfo, &scopeid)) return __FAIL; release_lock(); sa = encode_addr(domain, name, port, flowinfo, scopeid, #ifdef AF_LOCAL &sa_un, #endif &sa_in, #ifdef HAVE_IPV6 &sa_in6, #endif &len); acquire_lock(); if (!sa) return __FAIL; if (bind(fd, sa, len)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,listen,argc,argv) { #ifdef HAVE_LISTEN long fd, n; if (argc != 2 || !isint(argv[0], &fd) || !isint(argv[1], &n)) return __FAIL; if (listen(fd, n)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,accept,argc,argv) { #ifdef HAVE_ACCEPT long fd; struct sockaddr *sa; socklen_t len; expr x; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; if (!(sa = malloc(SOCKADDR_SIZE))) return __ERROR; release_lock(); fd = accept(fd, sa, &len); acquire_lock(); if (fd < 0) return __FAIL; else if (!(x = decode_addr(sa, len))) { close(fd); return NULL; } else return mktuplel(2, mkint(fd), x); #else return __FAIL; #endif } FUNCTION(clib,connect,argc,argv) { #ifdef HAVE_CONNECT long fd, domain, port; unsigned long flowinfo, scopeid; char *name; struct sockaddr *sa; #ifdef AF_LOCAL struct sockaddr_un sa_un; #endif struct sockaddr_in sa_in; #ifdef HAVE_IPV6 struct sockaddr_in6 sa_in6; #endif int len, res; if (argc != 2 || !isint(argv[0], &fd) || !isaddr(argv[1], &domain, &name, &port, &flowinfo, &scopeid)) return __FAIL; release_lock(); sa = encode_addr(domain, name, port, flowinfo, scopeid, #ifdef AF_LOCAL &sa_un, #endif &sa_in, #ifdef HAVE_IPV6 &sa_in6, #endif &len); if (!sa) { acquire_lock(); return __FAIL; } res = connect(fd, sa, len); acquire_lock(); if (res) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,getsockname,argc,argv) { #ifdef HAVE_GETSOCKNAME long fd; int res; struct sockaddr *sa; socklen_t len = SOCKADDR_SIZE; expr x; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; if (!(sa = malloc(SOCKADDR_SIZE))) return __ERROR; release_lock(); res = getsockname(fd, sa, &len); acquire_lock(); x = decode_addr(sa, len); free(sa); if (res) return __FAIL; else return x; #else return __FAIL; #endif } FUNCTION(clib,getpeername,argc,argv) { #ifdef HAVE_GETPEERNAME long fd; int res; struct sockaddr *sa; socklen_t len = SOCKADDR_SIZE; expr x; if (argc != 1 || !isint(argv[0], &fd)) return __FAIL; if (!(sa = malloc(SOCKADDR_SIZE))) return __ERROR; release_lock(); res = getpeername(fd, sa, &len); acquire_lock(); x = decode_addr(sa, len); free(sa); if (res) return __FAIL; else return x; #else return __FAIL; #endif } FUNCTION(clib,getsockopt,argc,argv) { #ifdef HAVE_GETSOCKOPT long fd, level, opt; socklen_t len = BUFSZ; void *v; if (argc != 3 || !isint(argv[0], &fd) || !isint(argv[1], &level) || !isint(argv[2], &opt)) return __FAIL; if (!(v = malloc(BUFSZ))) return __ERROR; if (getsockopt(fd, level, opt, v, &len)) return __FAIL; else if (len == 0) { free(v); return mkbstr(0, NULL); } else { void *v1 = realloc(v, len); if (v1) v = v1; return mkbstr(len, v); } #else return __FAIL; #endif } FUNCTION(clib,setsockopt,argc,argv) { #ifdef HAVE_SETSOCKOPT long fd, level, opt; bstr_t *val; if (argc != 4 || !isint(argv[0], &fd) || !isint(argv[1], &level) || !isint(argv[2], &opt) || !isobj(argv[3], type(ByteStr), (void**)&val)) return __FAIL; if (setsockopt(fd, level, opt, val->v, val->size)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,recv,argc,argv) { #ifdef HAVE_RECV long fd, flags, size; void *v; int res; if (argc != 3 || !isint(argv[0], &fd) || !isint(argv[1], &flags) || !isint(argv[2], &size) || size < 0) return __FAIL; if (!(v = malloc(size))) return __ERROR; release_lock(); res = recv(fd, v, size, flags); acquire_lock(); if (res < 0) { free(v); return __FAIL; } else if (res == 0) { free(v); return mkbstr(0, NULL); } else { void *v1 = realloc(v, res); if (v1) v = v1; return mkbstr(res, v); } #else return __FAIL; #endif } FUNCTION(clib,send,argc,argv) { #ifdef HAVE_SEND long fd, flags; int res; bstr_t *m; if (argc != 3 || !isint(argv[0], &fd) || !isint(argv[1], &flags) || !isobj(argv[2], type(ByteStr), (void**)&m)) return __FAIL; release_lock(); res = send(fd, m->v, m->size, flags); acquire_lock(); if (res < 0) return __FAIL; else return mkint(res); #else return __FAIL; #endif } FUNCTION(clib,recvfrom,argc,argv) { #ifdef HAVE_RECVFROM long fd, flags, size; void *v; int res; struct sockaddr *sa; socklen_t len = SOCKADDR_SIZE; expr x; if (argc != 3 || !isint(argv[0], &fd) || !isint(argv[1], &flags) || !isint(argv[2], &size) || size < 0) return __FAIL; if (!(v = malloc(size))) return __ERROR; if (!(sa = malloc(SOCKADDR_SIZE))) return __ERROR; release_lock(); res = recvfrom(fd, v, size, flags, sa, &len); acquire_lock(); x = decode_addr(sa, len); free(sa); if (res < 0) { free(v); return __FAIL; } else if (res == 0) { free(v); v = NULL; } else { void *v1 = realloc(v, res); if (v1) v = v1; } if (x) return mktuplel(2, x, mkbstr(res, v)); else return mkbstr(res, v); #else return __FAIL; #endif } FUNCTION(clib,sendto,argc,argv) { #ifdef HAVE_SENDTO long fd, flags, domain, port; unsigned long flowinfo, scopeid; char *name; struct sockaddr *sa; #ifdef AF_LOCAL struct sockaddr_un sa_un; #endif struct sockaddr_in sa_in; #ifdef HAVE_IPV6 struct sockaddr_in6 sa_in6; #endif int n, len, res; bstr_t *m; expr *xv; if (argc != 3 || !isint(argv[0], &fd) || !isint(argv[1], &flags) || !istuple(argv[2], &n, &xv) || n != 2 || !isaddr(xv[0], &domain, &name, &port, &flowinfo, &scopeid) || !isobj(xv[1], type(ByteStr), (void**)&m)) return __FAIL; release_lock(); sa = encode_addr(domain, name, port, flowinfo, scopeid, #ifdef AF_LOCAL &sa_un, #endif &sa_in, #ifdef HAVE_IPV6 &sa_in6, #endif &len); if (!sa) { acquire_lock(); return __FAIL; } res = sendto(fd, m->v, m->size, flags, sa, len); acquire_lock(); if (res < 0) return __FAIL; else return mkint(res); #else return __FAIL; #endif } static expr mkstrlist(char **l) { int i, n; expr *xv; for (i = 0; l[i]; i++) ; n = i; if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; for (i = 0; i < n; i++) xv[i] = mkstr(strdup(l[i])); return mklistv(n, xv); } /* net database functions ***************************************************/ #if defined(HAVE_GETHOSTBYNAME) || defined(HAVE_GETHOSTENT) static expr mkaddrlist(int addrtype, char **l) { int i, n; expr *xv; if (addrtype != AF_INET #ifdef HAVE_IPV6 && addrtype != AF_INET6 #endif ) return NULL; for (i = 0; l[i]; i++) ; n = i; if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; for (i = 0; i < n; i++) { const char *s; if (addrtype == AF_INET) { struct in_addr in; memcpy(&in, l[i], sizeof(struct in_addr)); s = inet_ntoa(in); #ifdef HAVE_IPV6 } else if (addrtype == AF_INET6) { char buf[BUFSZ]; s = inet_ntop(addrtype, l[i], buf, BUFSZ); #endif } else s = NULL; xv[i] = mkstr(strdup(s)); } return mklistv(n, xv); } #endif FUNCTION(clib,gethostbyname,argc,argv) { #ifdef HAVE_GETHOSTBYNAME char *name; struct hostent *h; if (argc == 1 && isstr(argv[0], &name) && (h = gethostbyname(name))) return mktuplel(4, mkstr(strdup(h->h_name)), mkstrlist(h->h_aliases), mkint(h->h_addrtype), mkaddrlist(h->h_addrtype, h->h_addr_list)); else #endif return __FAIL; } FUNCTION(clib,gethostbyaddr,argc,argv) { #ifdef HAVE_GETHOSTBYADDR char *cp, *addr = NULL; int len, type; struct hostent *h; #ifdef AF_INET struct in_addr sin_addr; #endif #ifdef HAVE_IPV6 struct in6_addr sin6_addr; #endif if (argc != 1 || !isstr(argv[0], &cp)) return __FAIL; #ifdef AF_INET #ifdef HAVE_INET_ATON if (!addr && inet_aton(cp, &sin_addr)) { #else memset(&sin_addr, 0, sizeof(sin_addr)); if (!addr && (sin_addr.s_addr = inet_addr(cp)) != INADDR_NONE) { #endif addr = (char*)&sin_addr; len = sizeof(sin_addr); type = AF_INET; } #endif #ifdef HAVE_IPV6 if (!addr && inet_pton(AF_INET6, cp, &sin6_addr)) { addr = (char*)&sin6_addr; len = sizeof(sin6_addr); type = AF_INET6; } #endif if (addr && (h = gethostbyaddr(addr, len, type))) return mktuplel(4, mkstr(strdup(h->h_name)), mkstrlist(h->h_aliases), mkint(h->h_addrtype), mkaddrlist(h->h_addrtype, h->h_addr_list)); else #endif return __FAIL; } FUNCTION(clib,gethostent,argc,argv) { #ifdef HAVE_GETHOSTENT if (argc == 0) { struct hostent *h; int i, n; expr *xv; sethostent(1); /* count entries */ for (n = 0, h = gethostent(); h; h = gethostent()) n++; /* rewind */ endhostent(); sethostent(1); /* allocate vector */ if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; /* list entries */ for (i = 0, h = gethostent(); h; h = gethostent()) if (i < n && (xv[i] = mktuplel(4, mkstr(strdup(h->h_name)), mkstrlist(h->h_aliases), mkint(h->h_addrtype), mkaddrlist(h->h_addrtype, h->h_addr_list)))) i++; else { while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return (i>=n)?__FAIL:__ERROR; } /* close */ endhostent(); /* check number of items read */ if (i < n) { /* read error */ while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return __FAIL; } /* return the list */ return mklistv(n, xv); } else #endif return __FAIL; } FUNCTION(clib,getprotobyname,argc,argv) { #ifdef HAVE_GETPROTOBYNAME char *name; struct protoent *p; if (argc == 1 && isstr(argv[0], &name) && (p = getprotobyname(name))) return mktuplel(3, mkstr(strdup(p->p_name)), mkstrlist(p->p_aliases), mkint(p->p_proto)); else #endif return __FAIL; } FUNCTION(clib,getprotobynumber,argc,argv) { #ifdef HAVE_GETPROTOBYNUMBER long proto; struct protoent *p; if (argc == 1 && isint(argv[0], &proto) && (p = getprotobynumber(proto))) return mktuplel(3, mkstr(strdup(p->p_name)), mkstrlist(p->p_aliases), mkint(p->p_proto)); else #endif return __FAIL; } FUNCTION(clib,getprotoent,argc,argv) { #ifdef HAVE_GETPROTOENT if (argc == 0) { struct protoent *p; int i, n; expr *xv; setprotoent(1); /* count entries */ for (n = 0, p = getprotoent(); p; p = getprotoent()) n++; /* rewind */ endprotoent(); setprotoent(1); /* allocate vector */ if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; /* list entries */ for (i = 0, p = getprotoent(); p; p = getprotoent()) if (i < n && (xv[i] = mktuplel(3, mkstr(strdup(p->p_name)), mkstrlist(p->p_aliases), mkint(p->p_proto)))) i++; else { while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return (i>=n)?__FAIL:__ERROR; } /* close */ endprotoent(); /* check number of items read */ if (i < n) { /* read error */ while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return __FAIL; } /* return the list */ return mklistv(n, xv); } else #endif return __FAIL; } FUNCTION(clib,getservbyname,argc,argv) { #ifdef HAVE_GETSERVBYNAME char *name, *proto; expr *xv; int n; struct servent *s; if (argc == 1 && (isstr(argv[0], &name) && (s = getservbyname(name, NULL)) || istuple(argv[0], &n, &xv) && n == 2 && isstr(xv[0], &name) && isstr(xv[1], &proto) && (s = getservbyname(name, proto)))) return mktuplel(4, mkstr(strdup(s->s_name)), mkstrlist(s->s_aliases), mkint(s->s_port), mkstr(strdup(s->s_proto))); else #endif return __FAIL; } FUNCTION(clib,getservbyport,argc,argv) { #ifdef HAVE_GETSERVBYPORT long port; char *proto; expr *xv; int n; struct servent *s; if (argc == 1 && (isint(argv[0], &port) && (s = getservbyport(port, NULL)) || istuple(argv[0], &n, &xv) && n == 2 && isint(xv[0], &port) && isstr(xv[1], &proto) && (s = getservbyport(port, proto)))) return mktuplel(4, mkstr(strdup(s->s_name)), mkstrlist(s->s_aliases), mkint(s->s_port), mkstr(strdup(s->s_proto))); else #endif return __FAIL; } FUNCTION(clib,getservent,argc,argv) { #ifdef HAVE_GETSERVENT if (argc == 0) { struct servent *s; int i, n; expr *xv; setservent(1); /* count entries */ for (n = 0, s = getservent(); s; s = getservent()) n++; /* rewind */ endservent(); setservent(1); /* allocate vector */ if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; /* list entries */ for (i = 0, s = getservent(); s; s = getservent()) if (i < n && (xv[i] = mktuplel(4, mkstr(strdup(s->s_name)), mkstrlist(s->s_aliases), mkint(s->s_port), mkstr(strdup(s->s_proto))))) i++; else { while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return (i>=n)?__FAIL:__ERROR; } /* close */ endservent(); /* check number of items read */ if (i < n) { /* read error */ while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return __FAIL; } /* return the list */ return mklistv(n, xv); } else #endif return __FAIL; } /* file and directory functions: ********************************************/ FUNCTION(clib,rename,argc,argv) { char *old, *new; if (argc == 2 && isstr(argv[0], &old) && isstr(argv[1], &new)) if (rename(old, new)) return __FAIL; else return mkvoid; else return __FAIL; } FUNCTION(clib,unlink,argc,argv) { char *name; if (argc == 1 && isstr(argv[0], &name)) if (unlink(name)) return __FAIL; else return mkvoid; else return __FAIL; } FUNCTION(clib,truncate,argc,argv) { #ifdef HAVE_TRUNCATE char *name; long len; if (argc != 2 || !isstr(argv[0], &name) || !isint(argv[1], &len)) return __FAIL; if (truncate(name, len)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,getcwd,argc,argv) { char pwd[BUFSZ]; if (argc == 0 && getcwd(pwd, BUFSZ)) { char *s = strdup(pwd); if (s) return mkstr(s); else return __ERROR; } else return __FAIL; } FUNCTION(clib,chdir,argc,argv) { char *name; if (argc == 1 && isstr(argv[0], &name)) if (chdir(name)) return __FAIL; else return mkvoid; else return __FAIL; } FUNCTION(clib,mkdir,argc,argv) { char *name; long mode; if (argc == 2 && isstr(argv[0], &name) && isint(argv[1], &mode)) #ifdef WIN32 /* mode argument is ignored */ if (mkdir(name)) #else if (mkdir(name, mode)) #endif return __FAIL; else return mkvoid; else return __FAIL; } FUNCTION(clib,rmdir,argc,argv) { char *name; if (argc == 1 && isstr(argv[0], &name)) if (rmdir(name)) return __FAIL; else return mkvoid; else return __FAIL; } FUNCTION(clib,readdir,argc,argv) { #ifdef HAVE_READDIR char *name; if (argc == 1 && isstr(argv[0], &name)) { DIR *dir; struct dirent *d; int i, n; expr *xv; /* open directory */ if (!(dir = opendir(name))) return __FAIL; /* count entries */ for (n = 0, d = readdir(dir); d; d = readdir(dir)) n++; /* rewind */ #ifdef HAVE_REWINDDIR rewinddir(dir); #else closedir(dir); if (!(dir = opendir(name))) return __FAIL; #endif /* allocate vector */ if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; /* list entries */ for (i = 0, d = readdir(dir); d; d = readdir(dir)) if (i < n && (xv[i] = mkstr(strdup(d->d_name)))) i++; else { while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return (i>=n)?__FAIL:__ERROR; } /* close directory */ closedir(dir); /* check number of items read */ if (i < n) { /* read error */ while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return __FAIL; } /* return the list */ return mklistv(n, xv); } else #endif return __FAIL; } FUNCTION(clib,link,argc,argv) { #ifdef HAVE_LINK char *old, *new; if (argc == 2 && isstr(argv[0], &old) && isstr(argv[1], &new)) if (link(old, new)) return __FAIL; else return mkvoid; else #endif return __FAIL; } FUNCTION(clib,symlink,argc,argv) { #ifdef HAVE_SYMLINK char *old, *new; if (argc == 2 && isstr(argv[0], &old) && isstr(argv[1], &new)) if (symlink(old, new)) return __FAIL; else return mkvoid; else #endif return __FAIL; } FUNCTION(clib,readlink,argc,argv) { #ifdef HAVE_READLINK char *name, buf[BUFSZ+1]; int n; if (argc == 1 && isstr(argv[0], &name)) if ((n = readlink(name, buf, BUFSZ)) < 0) return __FAIL; else { buf[n] = 0; return mkstr(strdup(buf)); } else #endif return __FAIL; } FUNCTION(clib,mkfifo,argc,argv) { #ifdef HAVE_MKFIFO char *name; long mode; if (argc == 2 && isstr(argv[0], &name) && isint(argv[1], &mode)) if (mkfifo(name, mode)) return __FAIL; else return mkvoid; else return __FAIL; #else return __FAIL; #endif } FUNCTION(clib,access,argc,argv) { #ifdef HAVE_ACCESS char *name; long mode; if (argc == 2 && isstr(argv[0], &name) && isint(argv[1], &mode)) if (access(name, mode)) return mkfalse; else return mktrue; else return __FAIL; #else return __FAIL; #endif } FUNCTION(clib,chmod,argc,argv) { #ifdef HAVE_CHMOD char *name; long mode; if (argc != 2 || !isstr(argv[0], &name) || !isint(argv[1], &mode)) return __FAIL; if (chmod(name, mode)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,chown,argc,argv) { #ifdef HAVE_CHOWN char *name; long uid, gid; if (argc != 3 || !isstr(argv[0], &name) || !isint(argv[1], &uid) || !isint(argv[2], &gid)) return __FAIL; if (chown(name, uid, gid)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,lchown,argc,argv) { #ifdef HAVE_LCHOWN char *name; long uid, gid; if (argc != 3 || !isstr(argv[0], &name) || !isint(argv[1], &uid) || !isint(argv[2], &gid)) return __FAIL; if (lchown(name, uid, gid)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } static int get_timeval(expr x, long *t) { double ft; if (isfloat(x, &ft)) if (ft < (double)INT_MIN || ft > (double)INT_MAX) return 0; else *t = (int)ft; else if (!isint(x, t)) return 0; return 1; } FUNCTION(clib,utime,argc,argv) { char *name; expr *xs; int n; long t1, t2; #ifdef HAVE_UTIME_H struct utimbuf ut; #endif if (argc != 2 || !isstr(argv[0], &name)) return __FAIL; if (istuple(argv[1], &n, &xs)) { if (n != 2 || !get_timeval(xs[0], &t1) || !get_timeval(xs[1], &t2)) return __FAIL; } else if (get_timeval(argv[1], &t1)) t2 = t1; else return __FAIL; #ifdef HAVE_UTIME_H ut.actime = t1; ut.modtime = t2; if (utime(name, &ut)) return __FAIL; else return mkvoid; #else return __FAIL; #endif } FUNCTION(clib,umask,argc,argv) { long mask; if (argc == 1 && isint(argv[0], &mask) && mask >= 0 && mask <= 0777) return mkint(umask(mask)); else return __FAIL; } FUNCTION(clib,stat,argc,argv) { char *name; if (argc == 1 && isstr(argv[0], &name)) { struct stat buf; if (stat(name, &buf)) return __FAIL; else return statres(&buf); } else return __FAIL; } #ifdef WIN32 #define lstat stat #endif FUNCTION(clib,lstat,argc,argv) { char *name; if (argc == 1 && isstr(argv[0], &name)) { struct stat buf; if (lstat(name, &buf)) return __FAIL; else return statres(&buf); } else return __FAIL; } /* process control **********************************************************/ FUNCTION(clib,system,argc,argv) { char *cmd; if (argc == 1 && isstr(argv[0], &cmd)) { int ret; errno = 0; release_lock(); ret = system(cmd); acquire_lock(); if (ret) if (errno) return __FAIL; else return mkint(ret); else return mkint(ret); } else return __FAIL; } FUNCTION(clib,fork,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else if (argc == 0/* && this_thread() == 0*/) { int pid = fork(); if (pid < 0) return __FAIL; else return mkint(pid); } else return __FAIL; #endif } FUNCTION(clib,exec,argc,argv) { char *prog, **args; if (argc == 2 && isstr(argv[0], &prog)) { int n; expr x, hd, tl; char *s; for (n = 0, x = argv[1]; iscons(x, &hd, &tl); n++) if (n >= INT_MAX) return __ERROR; else if (!isstr(hd, &s)) return __FAIL; else x = tl; if (!isnil(x)) return __FAIL; if (!(args = malloc((n+1)*sizeof(char*)))) return __ERROR; for (n = 0, x = argv[1]; iscons(x, &hd, &tl); n++) { isstr(hd, args+n); x = tl; } args[n] = NULL; #ifdef __MINGW32__ execvp(prog, (const char* const*)args); #else execvp(prog, args); #endif /* if we come here, something has gone wrong */ return __FAIL; } else return __FAIL; } static int spawn(int mode, char *prog, char *argv[], int *status) { #ifdef __MINGW32__ *status = spawnvp(mode, prog, (const char* const*)argv); return *status >= 0; #else int pid; if (mode == P_OVERLAY) { execvp(prog, argv); return 0; } switch ((pid = fork())) { case 0: execvp(prog, argv); case -1: return 0; } if (mode == P_WAIT) waitpid(pid, status, 0); else *status = pid; return 1; #endif } FUNCTION(clib,spawn,argc,argv) { char *prog, **args; if (argc == 2 && isstr(argv[0], &prog)) { int n, status; expr x, hd, tl; char *s; for (n = 0, x = argv[1]; iscons(x, &hd, &tl); n++) if (n >= INT_MAX) return __ERROR; else if (!isstr(hd, &s)) return __FAIL; else x = tl; if (!isnil(x)) return __FAIL; if (!(args = malloc((n+1)*sizeof(char*)))) return __ERROR; for (n = 0, x = argv[1]; iscons(x, &hd, &tl); n++) { isstr(hd, args+n); x = tl; } args[n] = NULL; if (spawn(P_NOWAIT, prog, args, &status)) return mkint(status); else return __FAIL; } else return __FAIL; } FUNCTION(clib,_spawn,argc,argv) { char *prog, **args; long mode; if (argc == 3 && isint(argv[0], &mode) && isstr(argv[1], &prog)) { int n, status; expr x, hd, tl; char *s; for (n = 0, x = argv[2]; iscons(x, &hd, &tl); n++) if (n >= INT_MAX) return __ERROR; else if (!isstr(hd, &s)) return __FAIL; else x = tl; if (!isnil(x)) return __FAIL; if (!(args = malloc((n+1)*sizeof(char*)))) return __ERROR; for (n = 0, x = argv[2]; iscons(x, &hd, &tl); n++) { isstr(hd, args+n); x = tl; } args[n] = NULL; if (spawn(mode, prog, args, &status)) return mkint(status); else return __FAIL; } else return __FAIL; } FUNCTION(clib,nice,argc,argv) { #ifdef HAVE_NICE long inc, res; if (argc != 1 || !isint(argv[0], &inc)) return __FAIL; errno = 0; res = nice(inc); if (res == -1 && errno) return __FAIL; else return mkint(res); #else return __FAIL; #endif } FUNCTION(clib,exit,argc,argv) { long code; if (argc == 1 && isint(argv[0], &code)) { exit(code); /* we shouldn't arrive here */ return __FAIL; } else return __FAIL; } FUNCTION(clib,pause,argc,argv) { #ifdef HAVE_PAUSE long sig; if (argc == 0) { release_lock(); pause(); acquire_lock(); return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,raise,argc,argv) { long sig; if (argc == 1 && isint(argv[0], &sig)) { if (raise(sig)) return __FAIL; else return mkvoid; } else return __FAIL; } FUNCTION(clib,kill,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long sig, pid; if (argc == 2 && isint(argv[0], &sig) && isint(argv[1], &pid)) { if (kill(pid, sig) < 0) return __FAIL; else return mkvoid; } else return __FAIL; #endif } FUNCTION(clib,getpid,argc,argv) { if (argc == 0) return mkint(getpid()); else return __FAIL; } FUNCTION(clib,getppid,argc,argv) { #ifdef HAVE_GETPPID if (argc == 0) return mkint(getppid()); else #endif return __FAIL; } #ifndef __MINGW32__ static expr waitres(int pid, int status) { if (pid < 0) return __FAIL; else if (pid == 0) return mkvoid; else return mktuplel(2, mkint(pid), mkint(status)); } #endif FUNCTION(clib,wait,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else if (argc == 0) { int status, pid; release_lock(); pid = wait(&status); acquire_lock(); return waitres(pid, status); } else return __FAIL; #endif } FUNCTION(clib,waitpid,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long pid, options; if (argc == 2 && isint(argv[0], &pid) && isint(argv[1], &options)) { int status; release_lock(); pid = waitpid(pid, &status, options); acquire_lock(); return waitres(pid, status); } else return __FAIL; #endif } FUNCTION(clib,isactive,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long s; if (argc == 1 && isint(argv[0], &s)) return mkfalse; else if (argc == 1 && isvoid(argv[0])) return mktrue; else return __FAIL; #endif } FUNCTION(clib,isexited,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long s; if (argc == 1 && isint(argv[0], &s)) { int status = s; if (WIFEXITED(status)) return mktrue; else return mkfalse; } else if (argc == 1 && isvoid(argv[0])) return mkfalse; else return __FAIL; #endif } FUNCTION(clib,exitstatus,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long s; if (argc == 1 && isint(argv[0], &s)) { int status = s; if (WIFEXITED(status)) return mkint(WEXITSTATUS(status)); else return __FAIL; } else return __FAIL; #endif } FUNCTION(clib,issignaled,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long s; if (argc == 1 && isint(argv[0], &s)) { int status = s; if (WIFSIGNALED(status)) return mktrue; else return mkfalse; } else if (argc == 1 && isvoid(argv[0])) return mkfalse; else return __FAIL; #endif } FUNCTION(clib,termsig,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long s; if (argc == 1 && isint(argv[0], &s)) { int status = s; if (WIFSIGNALED(status)) return mkint(WTERMSIG(status)); else return __FAIL; } else return __FAIL; #endif } FUNCTION(clib,isstopped,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long s; if (argc == 1 && isint(argv[0], &s)) { int status = s; if (WIFSTOPPED(status)) return mktrue; else return mkfalse; } else if (argc == 1 && isvoid(argv[0])) return mkfalse; else return __FAIL; #endif } FUNCTION(clib,stopsig,argc,argv) { #ifdef __MINGW32__ return __FAIL; #else long s; if (argc == 1 && isint(argv[0], &s)) { int status = s; if (WIFSTOPPED(status)) return mkint(WSTOPSIG(status)); else return __FAIL; } else return __FAIL; #endif } FUNCTION(clib,getenv,argc,argv) { char *name, *val; if (argc == 1 && isstr(argv[0], &name)) if ((val = getenv(name))) { char *s = strdup(val); if (s) return mkstr(s); else return __ERROR; } else return __FAIL; else return __FAIL; } FUNCTION(clib,setenv,argc,argv) { char *name, *val; if (argc == 2 && isstr(argv[0], &name) && isstr(argv[1], &val)) { /* According to POSIX, the string passed to putenv itself becomes part of the environment, so it has to be allocated dynamically. */ char *envstr = malloc(strlen(name)+strlen(val)+2); if (envstr) sprintf(envstr, "%s=%s", name, val); else return __ERROR; if (putenv(envstr)) return __FAIL; else return mkvoid; } else return __FAIL; } FUNCTION(clib,uname,argc,argv) { #ifdef HAVE_SYS_UTSNAME_H struct utsname u; if (argc == 0 && !uname(&u)) return mktuplel(5, mkstr(strdup(u.sysname)), mkstr(strdup(u.nodename)), mkstr(strdup(u.release)), mkstr(strdup(u.version)), mkstr(strdup(u.machine))); else #endif return __FAIL; } FUNCTION(clib,gethostname,argc,argv) { #ifdef HAVE_GETHOSTNAME char buf[BUFSZ+1]; if (argc == 0 && !gethostname(buf, BUFSZ)) { buf[BUFSZ] = 0; return mkstr(strdup(buf)); } else #endif return __FAIL; } #ifdef HAVE_GETGROUPS static expr mkgidlist(int n, GETGROUPS_T *l) { int i; expr *xv; if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; for (i = 0; i < n; i++) xv[i] = mkint(l[i]); return mklistv(n, xv); } #endif FUNCTION(clib,getgroups,argc,argv) { #ifdef HAVE_GETGROUPS if (argc == 0) { GETGROUPS_T l[BUFSZ+1]; int n = getgroups(BUFSZ, l); if (n >= 0) return mkgidlist(n, l); else return __FAIL; } else #endif return __FAIL; } FUNCTION(clib,setgroups,argc,argv) { #ifdef HAVE_SETGROUPS if (argc == 1) { int n, res; long gid; expr x, hd, tl; gid_t *l; for (n = 0, x = argv[0]; iscons(x, &hd, &tl) && isint(hd, &gid); x = tl) n++; if (!isnil(x)) return __FAIL; if (!(l = malloc(n*sizeof(gid_t)))) return __ERROR; for (n = 0, x = argv[0]; iscons(x, &hd, &tl) && isint(hd, &gid); x = tl) l[n++] = (gid_t)gid; res = setgroups(n, l); free(l); return res?__FAIL:mkvoid; } else #endif return __FAIL; } FUNCTION(clib,setuid,argc,argv) { #ifdef HAVE_SETUID long uid; if (argc == 1 && isint(argv[0], &uid) && !setuid(uid)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,setgid,argc,argv) { #ifdef HAVE_SETGID long gid; if (argc == 1 && isint(argv[0], &gid) && !setgid(gid)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,seteuid,argc,argv) { #ifdef HAVE_SETEUID long uid; if (argc == 1 && isint(argv[0], &uid) && !seteuid(uid)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,setegid,argc,argv) { #ifdef HAVE_SETEGID long gid; if (argc == 1 && isint(argv[0], &gid) && !setegid(gid)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,setreuid,argc,argv) { #ifdef HAVE_SETREUID long ruid, euid; if (argc == 2 && isint(argv[0], &ruid) && isint(argv[1], &euid) && !setreuid(ruid, euid)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,setregid,argc,argv) { #ifdef HAVE_SETREGID long rgid, egid; if (argc == 2 && isint(argv[0], &rgid) && isint(argv[1], &egid) && !setregid(rgid, egid)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,getuid,argc,argv) { #ifdef HAVE_GETUID if (argc == 0) return mkint(getuid()); else #endif return __FAIL; } FUNCTION(clib,geteuid,argc,argv) { #ifdef HAVE_GETEUID if (argc == 0) return mkint(geteuid()); else #endif return __FAIL; } FUNCTION(clib,getgid,argc,argv) { #ifdef HAVE_GETGID if (argc == 0) return mkint(getgid()); else #endif return __FAIL; } FUNCTION(clib,getegid,argc,argv) { #ifdef HAVE_GETEGID if (argc == 0) return mkint(getegid()); else #endif return __FAIL; } FUNCTION(clib,getlogin,argc,argv) { #ifdef HAVE_GETLOGIN char *s; if (argc == 0 && (s = getlogin())) return mkstr(strdup(s)); else #endif return __FAIL; } FUNCTION(clib,getpgid,argc,argv) { #ifdef HAVE_GETPGID long pid; if (argc == 1 && isint(argv[0], &pid) && (pid = getpgid(pid)) >= 0) return mkint(pid); else #endif return __FAIL; } FUNCTION(clib,setpgid,argc,argv) { #ifdef HAVE_SETPGID long pid, pgid; if (argc == 2 && isint(argv[0], &pid) && isint(argv[1], &pgid) && !setpgid(pid, pgid)) return mkvoid; else #endif return __FAIL; } FUNCTION(clib,getpgrp,argc,argv) { #ifdef HAVE_GETPGRP long pid; #ifdef GETPGRP_VOID if (argc == 0 && (pid = getpgrp()) >= 0) #else if (argc == 0 && (pid = getpgrp(0)) >= 0) #endif return mkint(pid); else #endif return __FAIL; } /* configure might detect wrong interface on these systems */ #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) #undef SETPGRP_VOID #endif FUNCTION(clib,setpgrp,argc,argv) { #ifdef HAVE_SETPGRP #ifdef SETPGRP_VOID if (argc == 0 && !setpgrp()) #else if (argc == 0 && !setpgrp(0, 0)) #endif return mkvoid; else #endif return __FAIL; } FUNCTION(clib,setsid,argc,argv) { #ifdef HAVE_SETSID long pid; if (argc == 0 && (pid = setsid()) >= 0) return mkint(pid); else #endif return __FAIL; } FUNCTION(clib,getsid,argc,argv) { #ifdef HAVE_GETSID long pid; if (argc == 1 && isint(argv[0], &pid) && (pid = getsid(pid)) >= 0) return mkint(pid); else #endif return __FAIL; } /* passwd/group database *****************************************************/ FUNCTION(clib,getpwuid,argc,argv) { #ifdef HAVE_GETPWUID long uid; struct passwd *pw; if (argc == 1 && isint(argv[0], &uid) && (pw = getpwuid(uid))) return mktuplel(7, mkstr(strdup(pw->pw_name)), mkstr(strdup(pw->pw_passwd)), mkint(pw->pw_uid), mkint(pw->pw_gid), mkstr(strdup(pw->pw_gecos)), mkstr(strdup(pw->pw_dir)), mkstr(strdup(pw->pw_shell))); else #endif return __FAIL; } FUNCTION(clib,getpwnam,argc,argv) { #ifdef HAVE_GETPWNAM char *name; struct passwd *pw; if (argc == 1 && isstr(argv[0], &name) && (pw = getpwnam(name))) return mktuplel(7, mkstr(strdup(pw->pw_name)), mkstr(strdup(pw->pw_passwd)), mkint(pw->pw_uid), mkint(pw->pw_gid), mkstr(strdup(pw->pw_gecos)), mkstr(strdup(pw->pw_dir)), mkstr(strdup(pw->pw_shell))); else #endif return __FAIL; } FUNCTION(clib,getpwent,argc,argv) { #ifdef HAVE_GETPWENT if (argc == 0) { struct passwd *pw; int i, n; expr *xv; setpwent(); /* count entries */ for (n = 0, pw = getpwent(); pw; pw = getpwent()) n++; /* rewind */ endpwent(); setpwent(); /* allocate vector */ if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; /* list entries */ for (i = 0, pw = getpwent(); pw; pw = getpwent()) if (i < n && (xv[i] = mktuplel(7, mkstr(strdup(pw->pw_name)), mkstr(strdup(pw->pw_passwd)), mkint(pw->pw_uid), mkint(pw->pw_gid), mkstr(strdup(pw->pw_gecos)), mkstr(strdup(pw->pw_dir)), mkstr(strdup(pw->pw_shell))))) i++; else { while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return (i>=n)?__FAIL:__ERROR; } /* close */ endpwent(); /* check number of items read */ if (i < n) { /* read error */ while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return __FAIL; } /* return the list */ return mklistv(n, xv); } else #endif return __FAIL; } FUNCTION(clib,getgrgid,argc,argv) { #ifdef HAVE_GETGRGID long gid; struct group *gr; if (argc == 1 && isint(argv[0], &gid) && (gr = getgrgid(gid))) return mktuplel(4, mkstr(strdup(gr->gr_name)), mkstr(strdup(gr->gr_passwd)), mkint(gr->gr_gid), mkstrlist(gr->gr_mem)); else #endif return __FAIL; } FUNCTION(clib,getgrnam,argc,argv) { #ifdef HAVE_GETGRNAM char *name; struct group *gr; if (argc == 1 && isstr(argv[0], &name) && (gr = getgrnam(name))) return mktuplel(4, mkstr(strdup(gr->gr_name)), mkstr(strdup(gr->gr_passwd)), mkint(gr->gr_gid), mkstrlist(gr->gr_mem)); else #endif return __FAIL; } FUNCTION(clib,getgrent,argc,argv) { #ifdef HAVE_GETGRENT if (argc == 0) { struct group *gr; int i, n; expr *xv; setgrent(); /* count entries */ for (n = 0, gr = getgrent(); gr; gr = getgrent()) n++; /* rewind */ endgrent(); setgrent(); /* allocate vector */ if (!(xv = malloc(n*sizeof(expr)))) return __ERROR; /* list entries */ for (i = 0, gr = getgrent(); gr; gr = getgrent()) if (i < n && (xv[i] = mktuplel(4, mkstr(strdup(gr->gr_name)), mkstr(strdup(gr->gr_passwd)), mkint(gr->gr_gid), mkstrlist(gr->gr_mem)))) i++; else { while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return (i>=n)?__FAIL:__ERROR; } /* close */ endgrent(); /* check number of items read */ if (i < n) { /* read error */ while (i > 0) dispose(xv[--i]); if (n > 0) free(xv); return __FAIL; } /* return the list */ return mklistv(n, xv); } else #endif return __FAIL; } FUNCTION(clib,crypt,argc,argv) { #ifdef HAVE_CRYPT char *key, *salt; if (argc == 2 && isstr(argv[0], &key) && isstr(argv[1], &salt) && (key = crypt(key, salt))) return mkstr(strdup(key)); else #endif return __FAIL; } /* errno and friends ********************************************************/ FUNCTION(clib,errno,argc,argv) { if (argc == 0) return mkint(errno); else return __FAIL; } FUNCTION(clib,seterrno,argc,argv) { long n; if (argc == 1 && isint(argv[0], &n)) { errno = n; return mkvoid; } else return __FAIL; } FUNCTION(clib,perror,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s)) { perror(s); return mkvoid; } else return __FAIL; } FUNCTION(clib,strerror,argc,argv) { long n; char *s; if (argc == 1 && isint(argv[0], &n) && (s = strerror(n))) return mkstr(strdup(s)); else return __FAIL; } /* multithreading: ********************************************************/ /* the thread table (make sure that the size matches with qdefs.h) */ #ifdef USE_THREADS #define MAXTHREAD 1024 #else #define MAXTHREAD 1 #endif typedef unsigned char bool; typedef struct { bool active, canceled, used; /* status */ expr arg; /* thread argument */ expr result; /* thread result, if any */ expr thread; /* thread object */ #ifdef USE_THREADS pthread_t id; /* thread id */ pthread_mutex_t exit_mutex; /* exit mutex and condition */ pthread_cond_t exit_cond; #ifdef WIN32 HANDLE handle; /* thread handle */ int pol; /* scheduling policy */ #endif #endif } THREAD; static THREAD threads[MAXTHREAD], *thr0 = threads; static int maxused, stamp; #ifdef WIN32 /* handle thread priorities under windows */ static int prio_class[] = {0,1,0,0}; static int max_prio_class(void) { int i; for (i = 3; i >= 0; i--) if (prio_class[i] > 0) break; i--; switch (i) { case -1: return IDLE_PRIORITY_CLASS; case 1: return HIGH_PRIORITY_CLASS; case 2: return REALTIME_PRIORITY_CLASS; default: return NORMAL_PRIORITY_CLASS; } } #endif DESTRUCTOR(clib,Thread,ptr) { #ifdef USE_THREADS THREAD *thr = (THREAD*)ptr; pthread_t id = thr->id; if (id == pthread_self()) { thr->thread = NULL; return; /* XXX FIXME: experimental stuff here. Second attempt to prevent waiting for dead child threads in thread destructor (see also ChangeLog entry from 2002-08-29). */ #if 0 } else if (!thr->active) #else } else if (!thr->used || !thr->thread) #endif return; #ifdef DEBUG printf("destroying thread %d (id %d)\n", thr-thr0, (int)id); #endif pthread_cancel(id); /* make sure that the thread object is not garbage-collected in the cancelled thread while we're already destroying it */ newref(thr->thread); /* wait for the canceled thread to finish */ release_lock(); pthread_join(id, NULL); acquire_lock(); unref(thr->thread); thr->active = thr->canceled = thr->used = 0; if (thr->arg) { freeref(thr->arg); thr->arg = NULL; } if (thr->result) { freeref(thr->result); thr->result = NULL; } if (thr->thread) thr->thread = NULL; pthread_mutex_destroy(&thr->exit_mutex); pthread_cond_destroy(&thr->exit_cond); #ifdef WIN32 CloseHandle(thr->handle); thr->handle = INVALID_HANDLE_VALUE; prio_class[thr->pol+1]--; #ifdef DEBUG printf("set priority class %d\n", max_prio_class()); #endif SetPriorityClass(GetCurrentProcess(), max_prio_class()); #endif /* deregister the thread with the interpreter */ fini_thread(thr-thr0); #endif } FUNCTION(clib,thread_no,argc,argv) { THREAD *thr; if (argc == 1 && isobj(argv[0], type(Thread), (void**)&thr)) { return mkint(thr-thr0); } else return __FAIL; } FUNCTION(clib,this_thread,argc,argv) { if (argc == 0) { THREAD *thr = thr0+this_thread(); if (thr->thread) return thr->thread; else if (thr == thr0) return (thr->thread = mkobj(type(Thread), thr)); else return __FAIL; } else return __FAIL; } #ifdef USE_THREADS static bool thread_ready; static pthread_mutex_t thread_ready_mutex = PTHREAD_MUTEX_INITIALIZER; static pthread_cond_t thread_ready_cond = PTHREAD_COND_INITIALIZER; static THREAD *nthr; static void my_mutex_unlock(void *mut) { pthread_mutex_unlock((pthread_mutex_t*)mut); } static void thread_canceled_proc(void *arg) { THREAD *thr = (THREAD*)arg; #ifdef DEBUG printf("thread %d (id %d) %s\n", thr-thr0, (int)thr->id, thr->result?"exited":"canceled"); #endif thr->canceled = (thr->result == NULL); exit_thread(thr-thr0); pthread_mutex_lock(&thr->exit_mutex); thr->active = 0; pthread_cond_broadcast(&thr->exit_cond); pthread_mutex_unlock(&thr->exit_mutex); } static void *thread_proc(void *arg) { expr x = (expr)arg, y; THREAD *thr; /* register the new thread with the interpreter */ int thrid = init_thread(); /* fill in the thread info */ pthread_mutex_lock(&thread_ready_mutex); if (thrid >= 0) { thr = thr0+thrid; if ((thr->thread = mkobj(type(Thread), thr))) { /* we count a new ref to the thread object here so that it does not get garbage-collected while we already start executing, before the thread function has had a chance to return the object */ newref(thr->thread); thr->arg = x; thr->result = NULL; thr->id = pthread_self(); #ifdef WIN32 if (!DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(), &thr->handle, 0, FALSE, DUPLICATE_SAME_ACCESS)) { dispose(thr->thread); goto errexit; } thr->pol = 0; prio_class[1]++; #ifdef DEBUG printf("set priority class %d\n", max_prio_class()); #endif SetPriorityClass(GetCurrentProcess(), max_prio_class()); #endif pthread_mutex_init(&thr->exit_mutex, NULL); pthread_cond_init(&thr->exit_cond, NULL); thr->active = 1; thr->canceled = 0; thr->used = 1; if (thr-thr0 > maxused) maxused = thr-thr0; nthr = thr; #ifdef DEBUG printf("initialized thread %d (id %d)\n", thr-thr0, (int)thr->id); #endif } else { errexit: exit_thread(thrid); fini_thread(thrid); #ifdef DEBUG printf("error initializing thread %d (id %d), exiting\n", thr-thr0, (int)thr->id); #endif } } #ifdef DEBUG else printf("error registering thread\n"); #endif /* exit if error */ if (!nthr) { thread_ready = 1; pthread_cond_signal(&thread_ready_cond); pthread_mutex_unlock(&thread_ready_mutex); return NULL; } /* signal that we're ready */ pthread_cleanup_push(thread_canceled_proc, thr); release_lock(); thread_ready = 1; pthread_cond_signal(&thread_ready_cond); pthread_mutex_unlock(&thread_ready_mutex); /* we're up and running, start evaluating the special argument */ #ifdef DEBUG printf("thread %d (id %d) up and running\n", thr-thr0, (int)thr->id); #endif acquire_lock(); y = newref(eval(x)); pthread_cleanup_pop(0); /* exit from thread */ thr->result = y; exit_thread(thr-thr0); /* signal that we've exited */ pthread_mutex_lock(&thr->exit_mutex); thr->active = 0; pthread_cond_broadcast(&thr->exit_cond); pthread_mutex_unlock(&thr->exit_mutex); #ifdef WIN32 CloseHandle(thr->handle); thr->handle = INVALID_HANDLE_VALUE; prio_class[thr->pol+1]--; #ifdef DEBUG printf("set priority class %d\n", max_prio_class()); #endif SetPriorityClass(GetCurrentProcess(), max_prio_class()); #endif #ifdef DEBUG printf("thread %d (id %d) exits\n", thr-thr0, (int)thr->id); #endif return (void*)y; } #endif FUNCTION(clib,thread,argc,argv) { #ifdef USE_THREADS if (argc == 1) { pthread_t id; int res; /* start the new thread */ pthread_cleanup_push(my_mutex_unlock, (void*)&thread_ready_mutex); pthread_mutex_lock(&thread_ready_mutex); thread_ready = 0; nthr = NULL; #ifdef DEBUG printf("starting new thread\n"); #endif if ((res = pthread_create(&id, NULL, thread_proc, newref(argv[0]))) == 0) { /* wait until the new thread signals that it's up and running */ #ifdef DEBUG printf("waiting for new thread\n"); #endif release_lock(); while (!thread_ready) pthread_cond_wait(&thread_ready_cond, &thread_ready_mutex); acquire_lock(); } pthread_cleanup_pop(1); if (res) return __FAIL; #ifdef DEBUG printf("new thread %s\n", nthr?"ready":"aborted"); #endif /* return the thread object */ if (nthr) return unref(nthr->thread); else return __ERROR; } else #endif return __FAIL; } FUNCTION(clib,return,argc,argv) { if (argc == 1) { THREAD *thr = thr0+this_thread(); #ifdef USE_THREADS if (thr > thr0) { thr->result = newref(argv[0]); pthread_exit((void*)thr->result); } else #endif return mksym(sym(halt)); } else return __FAIL; } FUNCTION(clib,cancel,argc,argv) { #ifdef USE_THREADS THREAD *thr; if (argc == 1 && isobj(argv[0], type(Thread), (void**)&thr)) { if (thr == thr0) return __FAIL; pthread_cancel(thr->id); return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,result,argc,argv) { #ifdef USE_THREADS THREAD *thr; if (argc == 1 && isobj(argv[0], type(Thread), (void**)&thr)) { if (thr == thr0) return __FAIL; /* wait for the thread to finish */ pthread_cleanup_push(my_mutex_unlock, (void*)&thr->exit_mutex); pthread_mutex_lock(&thr->exit_mutex); release_lock(); while (thr->active) pthread_cond_wait(&thr->exit_cond, &thr->exit_mutex); pthread_cleanup_pop(1); acquire_lock(); /* return result, if any */ if (thr->canceled || !thr->result) return __FAIL; else return thr->result; } else #endif return __FAIL; } FUNCTION(clib,yield,argc,argv) { if (argc == 0) { #ifdef USE_THREADS release_lock(); acquire_lock(); #endif return mkvoid; } else return __FAIL; } FUNCTION(clib,active,argc,argv) { THREAD *thr; if (argc == 1 && isobj(argv[0], type(Thread), (void**)&thr)) #ifdef USE_THREADS return thr->active?mktrue:mkfalse; #else return mktrue; #endif else return __FAIL; } FUNCTION(clib,canceled,argc,argv) { THREAD *thr; if (argc == 1 && isobj(argv[0], type(Thread), (void**)&thr)) #ifdef USE_THREADS return thr->canceled?mktrue:mkfalse; #else return mkfalse; #endif else return __FAIL; } /* NOTES ON WINDOWS SCHEDULING: The win32 pthread functions only allow SCHED_OTHER, so we provide our own implementation using the native Windows functions here. This is a bit kludgy since Windows does not provide real POSIX-compatible scheduling, but it's not too difficult to come up with a reasonable scheme. Here is how we chose to implement it: The policies 0, 1 and 2 are actually implemented as the process priority classes NORMAL_PRIORITY_CLASS, HIGH_PRIORITY_CLASS and REALTIME_PRIORITY_CLASS, respectively. There's also an extra policy -1 for the IDLE_PRIORITY_CLASS, which is rarely used (who wants to write a screensaver in Q?) but it's there anyway. Note that the *entire process* will run at higher scheduling priority when starting a thread using a policy >0. This means that the effective priorities of *all threads* will be beefed up once a realtime thread starts running; there's no way around this on Windows. Clib keeps track of the policies of all running threads and always chooses the lowest among these for the priority class of the process. For each of the policies we provide the priority values -3 (THREAD_PRIORITY_IDLE), -2 (THREAD_PRIORITY_LOWEST), -1 (THREAD_PRIORITY_BELOW_NORMAL), 0 (THREAD_PRIORITY_NORMAL), 1 (THREAD_PRIORITY_ABOVE_NORMAL), 2 (THREAD_PRIORITY_HIGHEST) and 3 (THREAD_PRIORITY_TIME_CRITICAL). Threads executing at priority -3 will only be executed when the system is idle. Priority 0 is the "normal" priority. The other priority levels provide some amount of control over which thread gets the bone first. Typically, a policy of 0 with zero priority will be used for ordinary threads, a policy of 1 with some positive priority value for a thread with moderate realtime requirements, and a policy of 2 if time is very critical (the latter should be used with utmost care since a process in the realtime class can easily freeze up Windows). This matches the typical usage on POSIX systems. */ FUNCTION(clib,setsched,argc,argv) { #ifdef USE_THREADS THREAD *thr; long pol, prio; if (argc == 3 && isobj(argv[0], type(Thread), (void**)&thr) && isint(argv[1], &pol) && isint(argv[2], &prio)) { #ifndef WIN32 struct sched_param param; int actpol; switch (pol) { case 0: pol = SCHED_OTHER; break; case 1: pol = SCHED_RR; break; case 2: pol = SCHED_FIFO; break; default: return __FAIL; } if (pthread_getschedparam(thr->id, &actpol, ¶m)) return __FAIL; else { param.sched_priority = prio; if (pthread_setschedparam(thr->id, pol, ¶m)) return __FAIL; else return mkvoid; } #else /* WIN32 */ if (thr->handle == INVALID_HANDLE_VALUE) return __FAIL; switch (prio) { case -3: prio = THREAD_PRIORITY_IDLE; break; case -2: prio = THREAD_PRIORITY_LOWEST; break; case -1: prio = THREAD_PRIORITY_BELOW_NORMAL; break; case 0: prio = THREAD_PRIORITY_NORMAL; break; case 1: prio = THREAD_PRIORITY_ABOVE_NORMAL; break; case 2: prio = THREAD_PRIORITY_HIGHEST; break; case 3: prio = THREAD_PRIORITY_TIME_CRITICAL; break; default: return __FAIL; } prio_class[thr->pol+1]--; prio_class[pol+1]++; #ifdef DEBUG printf("set priority class %d\n", max_prio_class()); #endif if (!SetPriorityClass(GetCurrentProcess(), max_prio_class())) { prio_class[pol+1]--; prio_class[thr->pol+1]++; return __FAIL; } else { #ifdef DEBUG printf("set priority %d for thread %d (id %d, handle %d)\n", prio, thr-thr0, (int)thr->id, (int)thr->handle); #endif if (SetThreadPriority(thr->handle, prio)) { thr->pol = pol; return mkvoid; } else { prio_class[pol+1]--; prio_class[thr->pol+1]++; SetPriorityClass(GetCurrentProcess(), max_prio_class()); return __FAIL; } } #endif } else #endif return __FAIL; } FUNCTION(clib,getsched,argc,argv) { #ifdef USE_THREADS THREAD *thr; int pol, prio; if (argc == 1 && isobj(argv[0], type(Thread), (void**)&thr)) { #ifndef WIN32 struct sched_param param; if (pthread_getschedparam(thr->id, &pol, ¶m)) return __FAIL; else { switch(pol) { case SCHED_OTHER: pol = 0; break; case SCHED_RR: pol = 1; break; case SCHED_FIFO: pol = 2; break; default: return __FAIL; } prio = param.sched_priority; return mktuplel(2, mkint(pol), mkint(prio)); } #else /* WIN32 */ if (thr->handle == INVALID_HANDLE_VALUE) return __FAIL; switch (GetThreadPriority(thr->handle)) { case THREAD_PRIORITY_IDLE: prio = -3; break; case THREAD_PRIORITY_LOWEST: prio = -2; break; case THREAD_PRIORITY_BELOW_NORMAL: prio = -1; break; case THREAD_PRIORITY_NORMAL: prio = 0; break; case THREAD_PRIORITY_ABOVE_NORMAL: prio = 1; break; case THREAD_PRIORITY_HIGHEST: prio = 2; break; case THREAD_PRIORITY_TIME_CRITICAL: prio = 3; break; default: return __FAIL; } pol = thr->pol; return mktuplel(2, mkint(pol), mkint(prio)); #endif } else #endif return __FAIL; } #ifdef USE_THREADS /* mutex data structure */ typedef struct { pthread_mutex_t mut; pthread_mutexattr_t attr, *attrp; int stamp; } my_mutex_t; /* condition data structure */ typedef struct { pthread_mutex_t mut; pthread_cond_t cond; bool set; int stamp; } my_cond_t; /* semaphore data structure */ /* KLUDGE ALERT: MacOS X doesn't have unnamed semaphores, se we use named ones instead. FIXME: Maybe we should provide our own lightweight semaphore implementation here? */ #ifdef __APPLE__ #define NAMED_SEM #endif #ifdef NAMED_SEM static unsigned long sem_counter = 0; static char *new_sem_name(void) { static char sem_name[32]; sprintf(sem_name, "/clib_sem-%d-%4.4d", getpid(), sem_counter++); return sem_name; } #endif typedef struct expr_queue_entry { expr val; struct expr_queue_entry *next; } expr_queue_entry_t; typedef struct { long size; expr_queue_entry_t *head, *tail, *last_tail; } expr_queue_t; typedef struct { pthread_mutex_t mut; sem_t *semp; #ifndef NAMED_SEM sem_t sem; #endif pthread_cond_t cond; expr_queue_t queue; int stamp; long max; } my_sem_t; static void init_queue(expr_queue_t *queue) { queue->size = 0; queue->head = queue->tail = queue->last_tail = NULL; } static void free_queue(expr_queue_t *queue) { expr_queue_entry_t *head = queue->head; while (head) { expr_queue_entry_t *next = head->next; if (head->val) freeref(head->val); free(head); head = next; } } static expr_queue_entry_t *enqueue_expr(expr_queue_t *queue, expr val) { expr_queue_entry_t *new_tail = malloc(sizeof(expr_queue_entry_t)); if (!new_tail) return NULL; new_tail->val = newref(val); new_tail->next = NULL; if (queue->tail) { queue->tail->next = new_tail; queue->last_tail = queue->tail; queue->tail = new_tail; } else { queue->last_tail = NULL; queue->head = queue->tail = new_tail; } queue->size++; return new_tail; } static expr_queue_entry_t *unenqueue_expr(expr_queue_t *queue) { if (queue->tail) { freeref(queue->tail->val); free(queue->tail); queue->tail = queue->last_tail; if (queue->tail) queue->tail->next = NULL; else queue->head = NULL; queue->last_tail = NULL; queue->size--; return queue->tail; } else return NULL; } static expr dequeue_expr(expr_queue_t *queue) { expr val; if (!queue->head) return NULL; val = queue->head->val; if (queue->head == queue->tail) { free(queue->head); queue->head = queue->tail = queue->last_tail = NULL; } else { expr_queue_entry_t *next = queue->head->next; if (queue->last_tail == queue->head) queue->last_tail = NULL; free(queue->head); queue->head = next; } queue->size--; return val; } /* clean up after fork */ static check_mut(my_mutex_t *mut) { if (mut && mut->stamp != stamp) { pthread_mutex_init(&mut->mut, mut->attrp); mut->stamp = stamp; } } static check_cond(my_cond_t *cond) { if (cond && cond->stamp != stamp) { pthread_mutex_init(&cond->mut, NULL); pthread_cond_init(&cond->cond, NULL); cond->set = 0; cond->stamp = stamp; } } static check_sem(my_sem_t *sem) { if (sem && sem->stamp != stamp) { pthread_mutex_init(&sem->mut, NULL); #ifdef NAMED_SEM sem->semp = sem_open(new_sem_name(), O_CREAT, 0600, sem->queue.size); if (sem->semp == (sem_t*)SEM_FAILED) sem->semp = NULL; #else sem_init(&sem->sem, 0, sem->queue.size); sem->semp = &sem->sem; #endif pthread_cond_init(&sem->cond, NULL); sem->stamp = stamp; } } #endif /* destructors */ DESTRUCTOR(clib,Mutex,ptr) { #ifdef USE_THREADS my_mutex_t *mut = (my_mutex_t*)ptr; if (mut) { pthread_mutex_destroy(&mut->mut); if (mut->attrp) pthread_mutexattr_destroy(mut->attrp); free(mut); } #endif } DESTRUCTOR(clib,Cond,ptr) { #ifdef USE_THREADS my_cond_t *cond = (my_cond_t*)ptr; if (cond) { pthread_mutex_destroy(&cond->mut); pthread_cond_destroy(&cond->cond); free(cond); } #endif } DESTRUCTOR(clib,Sem,ptr) { #ifdef USE_THREADS my_sem_t *sem = (my_sem_t*)ptr; if (sem) { pthread_mutex_destroy(&sem->mut); #ifdef NAMED_SEM sem_close(sem->semp); #else sem_destroy(&sem->sem); #endif sem->semp = NULL; pthread_cond_destroy(&sem->cond); free_queue(&sem->queue); free(sem); } #endif } /* constructors */ FUNCTION(clib,mutex,argc,argv) { #ifdef USE_THREADS my_mutex_t *mut = (my_mutex_t*)malloc(sizeof(my_mutex_t)); if (mut) { mut->attrp = NULL; pthread_mutex_init(&mut->mut, NULL); mut->stamp = stamp; return mkobj(type(Mutex), mut); } else return __ERROR; #else return __FAIL; #endif } FUNCTION(clib,errorchecking_mutex,argc,argv) { #ifdef USE_THREADS my_mutex_t *mut = (my_mutex_t*)malloc(sizeof(my_mutex_t)); if (mut) { mut->attrp = &mut->attr; pthread_mutexattr_init(mut->attrp); pthread_mutexattr_settype(mut->attrp, PTHREAD_MUTEX_ERRORCHECK); pthread_mutex_init(&mut->mut, mut->attrp); mut->stamp = stamp; return mkobj(type(Mutex), mut); } else return __ERROR; #else return __FAIL; #endif } FUNCTION(clib,recursive_mutex,argc,argv) { #ifdef USE_THREADS my_mutex_t *mut = (my_mutex_t*)malloc(sizeof(my_mutex_t)); if (mut) { mut->attrp = &mut->attr; pthread_mutexattr_init(mut->attrp); pthread_mutexattr_settype(mut->attrp, PTHREAD_MUTEX_RECURSIVE); pthread_mutex_init(&mut->mut, mut->attrp); mut->stamp = stamp; return mkobj(type(Mutex), mut); } else return __ERROR; #else return __FAIL; #endif } FUNCTION(clib,cond,argc,argv) { #ifdef USE_THREADS my_cond_t *cond = (my_cond_t*)malloc(sizeof(my_cond_t)); if (cond) { pthread_mutex_init(&cond->mut, NULL); pthread_cond_init(&cond->cond, NULL); cond->set = 0; cond->stamp = stamp; return mkobj(type(Cond), cond); } else return __ERROR; #else return __FAIL; #endif } FUNCTION(clib,sem,argc,argv) { #ifdef USE_THREADS my_sem_t *sem = (my_sem_t*)malloc(sizeof(my_sem_t)); if (sem) { pthread_mutex_init(&sem->mut, NULL); #ifdef NAMED_SEM sem->semp = sem_open(new_sem_name(), O_CREAT, 0600, 0); if (sem->semp == (sem_t*)SEM_FAILED) { free(sem); return __ERROR; } #else sem_init(&sem->sem, 0, 0); sem->semp = &sem->sem; #endif pthread_cond_init(&sem->cond, NULL); init_queue(&sem->queue); sem->stamp = stamp; sem->max = 0; return mkobj(type(Sem), sem); } else return __ERROR; #else return __FAIL; #endif } FUNCTION(clib,bounded_sem,argc,argv) { #ifdef USE_THREADS long max; if (argc == 1 && isint(argv[0], &max) && max > 0) { my_sem_t *sem = (my_sem_t*)malloc(sizeof(my_sem_t)); if (sem) { pthread_mutex_init(&sem->mut, NULL); #ifdef NAMED_SEM sem->semp = sem_open(new_sem_name(), O_CREAT, 0600, 0); if (sem->semp == (sem_t*)SEM_FAILED) { free(sem); return __ERROR; } #else sem_init(&sem->sem, 0, 0); sem->semp = &sem->sem; #endif pthread_cond_init(&sem->cond, NULL); init_queue(&sem->queue); sem->stamp = stamp; sem->max = max; return mkobj(type(Sem), sem); } else return __ERROR; } else #endif return __FAIL; } /* interface ops */ FUNCTION(clib,lock,argc,argv) { #ifdef USE_THREADS my_mutex_t *mut; if (argc == 1 && isobj(argv[0], type(Mutex), (void**)&mut)) { int res; check_mut(mut); release_lock(); res = pthread_mutex_lock(&mut->mut); acquire_lock(); if (res) return __FAIL; else return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,unlock,argc,argv) { #ifdef USE_THREADS my_mutex_t *mut; if (argc == 1 && isobj(argv[0], type(Mutex), (void**)&mut)) { check_mut(mut); if (pthread_mutex_unlock(&mut->mut)) return __FAIL; else return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,try,argc,argv) { #ifdef USE_THREADS my_mutex_t *mut; my_sem_t *sem; if (argc == 1) if (isobj(argv[0], type(Mutex), (void**)&mut)) { check_mut(mut); if (pthread_mutex_trylock(&mut->mut)) return __FAIL; else return mkvoid; } else if (isobj(argv[0], type(Sem), (void**)&sem)) { int res; expr val; check_sem(sem); release_lock(); res = sem_trywait(sem->semp); if (!res) { pthread_mutex_lock(&sem->mut); if (sem->queue.size <= 0) res = -1; else { val = dequeue_expr(&sem->queue); if (sem->max) pthread_cond_signal(&sem->cond); } pthread_mutex_unlock(&sem->mut); } acquire_lock(); if (res) return __FAIL; else return unref(val); } else return __FAIL; else #endif return __FAIL; } FUNCTION(clib,signal,argc,argv) { #ifdef USE_THREADS my_cond_t *cond; if (argc == 1 && isobj(argv[0], type(Cond), (void**)&cond)) { int res; check_cond(cond); pthread_mutex_lock(&cond->mut); res = pthread_cond_signal(&cond->cond); if (!res) cond->set = 1; pthread_mutex_unlock(&cond->mut); if (res) return __FAIL; else return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,broadcast,argc,argv) { #ifdef USE_THREADS my_cond_t *cond; if (argc == 1 && isobj(argv[0], type(Cond), (void**)&cond)) { int res; check_cond(cond); pthread_mutex_lock(&cond->mut); res = pthread_cond_broadcast(&cond->cond); if (!res) cond->set = 1; pthread_mutex_unlock(&cond->mut); if (res) return __FAIL; else return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,await,argc,argv) { #ifdef USE_THREADS my_cond_t *cond; int n; expr *v; double t; struct timespec tspec; bool tset = 0; if (argc == 1 && (isobj(argv[0], type(Cond), (void**)&cond) || istuple(argv[0], &n, &v) && n == 2 && (tset = 1) && isobj(v[0], type(Cond), (void**)&cond) && (isfloat(v[1], &t) || ismpz_float(v[1], &t)))) { int res = 0; check_cond(cond); if (tset) { double ip, fp; unsigned long secs; unsigned long nsecs; fp = modf(t/1e3, &ip); if (ip > LONG_MAX) { ip = (double)LONG_MAX; fp = 0.0; } secs = (unsigned long)ip; nsecs = (unsigned long)(fp*1e9); tspec.tv_sec = secs; tspec.tv_nsec = nsecs; } pthread_cleanup_push(my_mutex_unlock, (void*)&cond->mut); pthread_mutex_lock(&cond->mut); release_lock(); cond->set = 0; while (!cond->set && !res) if (tset) res = pthread_cond_timedwait(&cond->cond, &cond->mut, &tspec); else res = pthread_cond_wait(&cond->cond, &cond->mut); pthread_cleanup_pop(1); acquire_lock(); if (res) return __FAIL; else return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,post,argc,argv) { #ifdef USE_THREADS my_sem_t *sem; if (argc == 2 && isobj(argv[0], type(Sem), (void**)&sem)) { int res = 0; check_sem(sem); if (sem->max) { pthread_cleanup_push(my_mutex_unlock, (void*)&sem->mut); pthread_mutex_lock(&sem->mut); release_lock(); while (sem->queue.size >= sem->max && !res) res = pthread_cond_wait(&sem->cond, &sem->mut); if (!res) { if (!enqueue_expr(&sem->queue, argv[1])) res = -1; if (!res) { res = sem_post(sem->semp); if (res) unenqueue_expr(&sem->queue); } } pthread_cleanup_pop(1); acquire_lock(); } else { pthread_mutex_lock(&sem->mut); if (!enqueue_expr(&sem->queue, argv[1])) res = -1; if (!res) { res = sem_post(sem->semp); if (res) unenqueue_expr(&sem->queue); } pthread_mutex_unlock(&sem->mut); } if (res) return (res==-1)?__ERROR:__FAIL; else return mkvoid; } else #endif return __FAIL; } FUNCTION(clib,get,argc,argv) { expr *x; #ifdef USE_THREADS my_sem_t *sem; if (argc == 1 && isobj(argv[0], type(Ref), (void**)&x)) return *x; else if (argc == 1 && isobj(argv[0], type(Sem), (void**)&sem)) { int res; expr val; check_sem(sem); release_lock(); retry: res = sem_wait(sem->semp); if (!res) { pthread_mutex_lock(&sem->mut); if (sem->queue.size <= 0) { pthread_mutex_unlock(&sem->mut); goto retry; } val = dequeue_expr(&sem->queue); if (sem->max) pthread_cond_signal(&sem->cond); pthread_mutex_unlock(&sem->mut); } acquire_lock(); if (res) return __FAIL; else return unref(val); } else #else if (argc == 1 && isobj(argv[0], type(Ref), (void**)&x)) return *x; #endif return __FAIL; } FUNCTION(clib,get_size,argc,argv) { #ifdef USE_THREADS my_sem_t *sem; if (argc == 1 && isobj(argv[0], type(Sem), (void**)&sem)) { long size; check_sem(sem); pthread_mutex_lock(&sem->mut); size = sem->queue.size; pthread_mutex_unlock(&sem->mut); return mkint(size); } else #endif return __FAIL; } FUNCTION(clib,get_bound,argc,argv) { #ifdef USE_THREADS my_sem_t *sem; if (argc == 1 && isobj(argv[0], type(Sem), (void**)&sem)) { check_sem(sem); return mkint(sem->max); } else #endif return __FAIL; } /* references: ************************************************************/ DESTRUCTOR(clib,Ref,ptr) { freeref(*((expr*)ptr)); free(ptr); } FUNCTION(clib,ref,argc,argv) { if (argc == 1) { expr *x = (expr*)malloc(sizeof(expr)); if (x) { *x = newref(argv[0]); return mkobj(type(Ref), x); } else return __ERROR; } else return __FAIL; } FUNCTION(clib,put,argc,argv) { expr *x; if (argc == 2 && isobj(argv[0], type(Ref), (void**)&x)) { freeref(*x); *x = newref(argv[1]); return mkvoid; } else return __FAIL; } /* see the semaphore operations above for a definition of get */ /* time functions: ********************************************************/ static struct tm *encode_tmval(expr x) { static struct tm tm; expr *xs; int n; long k; if (!istuple(x, &n, &xs) || n != 9) return NULL; if (!isint(xs[0], &k)) return NULL; else tm.tm_year = k; if (!isint(xs[1], &k)) return NULL; else tm.tm_mon = k; if (!isint(xs[2], &k)) return NULL; else tm.tm_mday = k; if (!isint(xs[3], &k)) return NULL; else tm.tm_hour = k; if (!isint(xs[4], &k)) return NULL; else tm.tm_min = k; if (!isint(xs[5], &k)) return NULL; else tm.tm_sec = k; if (!isint(xs[6], &k)) return NULL; else tm.tm_wday = k; if (!isint(xs[7], &k)) return NULL; else tm.tm_yday = k; if (!isint(xs[8], &k)) return NULL; else tm.tm_isdst = k; return &tm; } static expr decode_tmval(struct tm *tm) { if (!tm) return __FAIL; return mktuplel(9, mkint(tm->tm_year), mkint(tm->tm_mon), mkint(tm->tm_mday), mkint(tm->tm_hour), mkint(tm->tm_min), mkint(tm->tm_sec), mkint(tm->tm_wday), mkint(tm->tm_yday), mkint(tm->tm_isdst)); } FUNCTION(clib,tzname,argc,argv) { #if HAVE_DECL_TZNAME if (argc == 0) return mktuplel(2, mkstr(strdup(tzname[0])), mkstr(strdup(tzname[1]))); else #endif return __FAIL; } FUNCTION(clib,timezone,argc,argv) { #if HAVE_DECL_TZNAME && HAVE_DECL_DAYLIGHT if (argc == 0) return mkint(timezone); else #endif return __FAIL; } FUNCTION(clib,daylight,argc,argv) { #if HAVE_DECL_TZNAME && HAVE_DECL_DAYLIGHT if (argc == 0) return mkint(daylight); else #endif return __FAIL; } FUNCTION(clib,ctime,argc,argv) { if (argc == 1) { long it; time_t t; char *s; if (!get_timeval(argv[0], &it)) return __FAIL; t = it; if ((s = asctime(localtime(&t)))) return mkstr(strdup(s)); else return __FAIL; } else return __FAIL; } FUNCTION(clib,gmtime,argc,argv) { if (argc == 1) { long it; time_t t; if (!get_timeval(argv[0], &it)) return __FAIL; t = it; return decode_tmval(gmtime(&t)); } else return __FAIL; } FUNCTION(clib,localtime,argc,argv) { if (argc == 1) { long it; time_t t; if (!get_timeval(argv[0], &it)) return __FAIL; t = it; return decode_tmval(localtime(&t)); } else return __FAIL; } FUNCTION(clib,mktime,argc,argv) { if (argc == 1) { struct tm *tm; if (!(tm = encode_tmval(argv[0]))) return __FAIL; else return mkint((long)mktime(tm)); } else return __FAIL; } FUNCTION(clib,asctime,argc,argv) { if (argc == 1) { struct tm *tm; char *s; if (!(tm = encode_tmval(argv[0])) || !(s = asctime(tm))) return __FAIL; else return mkstr(strdup(s)); } else return __FAIL; } FUNCTION(clib,strftime,argc,argv) { char *format; if (argc == 2 && isstr(argv[0], &format)) { struct tm *tm; char s[BUFSZ+1]; if (!(tm = encode_tmval(argv[1]))) return __FAIL; else { /* The interface to strftime is rather brain-damaged since it returns zero both in case of a buffer overflow and when the resulting string is empty. We just pretend that there cannot be any errors and return an empty string in both cases. */ if (!strftime(s, BUFSZ, format, tm)) *s = 0; return mkstr(strdup(s)); } } else return __FAIL; } FUNCTION(clib,clock,argc,argv) { if (argc == 0) { clock_t t = clock(); if (t == (clock_t)-1) return __FAIL; else return mkint((long)t); } else return __FAIL; } FUNCTION(clib,times,argc,argv) { #ifdef HAVE_TIMES if (argc == 0) { struct tms ts; clock_t t = times(&ts); if (t == (clock_t)-1) return __FAIL; else return mktuplel(5, mkint(t), mkint((long)ts.tms_utime), mkint((long)ts.tms_stime), mkint((long)ts.tms_cutime), mkint((long)ts.tms_cstime)); } else #endif return __FAIL; } /* filename globbing: *****************************************************/ FUNCTION(clib,fnmatch,argc,argv) { char *pattern, *s; if (argc == 2 && isstr(argv[0], &pattern) && isstr(argv[1], &s)) if (fnmatch(pattern, s, 0)) return mkfalse; else return mktrue; else return __FAIL; } FUNCTION(clib,glob,argc,argv) { char *pattern; if (argc == 1 && isstr(argv[0], &pattern)) { glob_t g; int res; g.gl_offs = 0; res = glob(pattern, 0, NULL, &g); if (res == GLOB_NOMATCH) return mknil; else if (res) return __FAIL; else { expr x = mknil; int i = g.gl_pathc; while (x && --i >= 0) x = mkcons(mkstr(strdup(g.gl_pathv[i])), x); globfree(&g); if (x) return x; else return __ERROR; } } else return __FAIL; } /* regular expression matching: *******************************************/ /* regexp stack */ typedef struct { unsigned done:1, global:2, matched:1; int cflags, eflags; regex_t rx; regmatch_t *matches; char *s, *p, *start; } regstate_t; long regalloc = 0; regstate_t *regstack = NULL, *regp = NULL; char regmsg[BUFSZ]; #define REGALLOC 50 static int reg_push(void) { if (!regstack) if ((regstack = malloc(REGALLOC*sizeof(regstate_t)))) { regalloc = REGALLOC; regp = regstack; } else return -1; else if (!regp) regp = regstack; else if (regp-regstack+1 == regalloc) { regstate_t *newstack = realloc(regstack, (regalloc+REGALLOC)*sizeof(regstate_t)); if (newstack) { regstack = newstack; regp = regstack+regalloc; regalloc += REGALLOC; } else return -1; } else regp++; regp->done = regp->global = regp->matched = 0; regp->cflags = regp->eflags = 0; regp->matches = NULL; regp->s = regp->p = regp->start = NULL; return 0; } static void reg_pop(void) { if (!regp) return; regfree(®p->rx); if (regp->matches) free(regp->matches); if (regp->s) free(regp->s); if (regp > regstack) regp--; else regp = NULL; } /* push a new expression on the stack */ static int reg_add(char *pattern, char *s, int global, int cflags, int eflags) { int ret; if (regp && regp->done) reg_pop(); if (reg_push()) return -1; regp->global = global; regp->cflags = cflags; regp->eflags = eflags; ret = regcomp(®p->rx, pattern, REG_EXTENDED|cflags); *regmsg = 0; if (ret) { regerror(ret, ®p->rx, regmsg, BUFSZ); reg_pop(); return ret; } if (!(regp->s = strdup(s))) { reg_pop(); return -1; } regp->p = regp->s; regp->start = NULL; if (!(regp->matches = malloc((regp->rx.re_nsub+1)*sizeof(regmatch_t)))) { reg_pop(); return -1; } return 0; } /* search */ static int reg_flags(char *p) { int flags; flags = regp->eflags; if (p > regp->s) if (regp->cflags & REG_NEWLINE) if (p[-1] == '\n') flags &= ~REG_NOTBOL; else flags |= REG_NOTBOL; else flags |= REG_NOTBOL; return flags; } static int reg_search(void) { int ret; char *prev; while (regp && regp->done && regp>regstack) reg_pop(); if (!regp) return -1; if (regp->matched) /* note the beginning of the previous match */ prev = regp->start+regp->matches[0].rm_so; regp->start = regp->p; if (regp->global || !regp->matched) { ret = regexec(®p->rx, regp->p, regp->rx.re_nsub+1, regp->matches, reg_flags(regp->p)); if (!ret) { if (regp->matched) if (regp->matches[0].rm_eo == regp->matches[0].rm_so && regp->p == prev) /* an extra empty match: if not at end of string then advance to the next position and try again; otherwise simply ignore this match and fail */ if (*regp->p) { int i; /* this cannot fail since we can always match the empty string */ ret = regexec(®p->rx, regp->p+1, regp->rx.re_nsub+1, regp->matches, reg_flags(regp->p+1)); /* translate offsets */ for (i = 0; i <= regp->rx.re_nsub; i++) { regp->matches[i].rm_so++; regp->matches[i].rm_eo++; } } else ret = REG_NOMATCH; regp->matched = 1; } } else ret = REG_NOMATCH; *regmsg = 0; if (ret) { regp->done = 1; regerror(ret, ®p->rx, regmsg, BUFSZ); } else if (regp->global == 2 && regp->matches[0].rm_eo > regp->matches[0].rm_so) regp->p += regp->matches[0].rm_so+1; else regp->p += regp->matches[0].rm_eo; return ret; } /* stop search */ static void reg_done(void) { if (regp) { regp->start = regp->p; regp->done = 1; } } /* return matches */ static size_t reg_nmatches(void) { if (regp) return regp->rx.re_nsub; else return 0; } static long reg_start(void) { if (regp && regp->start) return regp->start-regp->s; else return -1; } static char *reg_skipstr(void) { if (regp && regp->start) return regp->start; else return NULL; } static long reg_pos(int i) { if (regp && regp->start && 0 <= i && i <= regp->rx.re_nsub) if (!regp->done && regp->matches[i].rm_so >= 0) return regp->start+regp->matches[i].rm_so-regp->s; else return -1; else return -1; } static long reg_end(int i) { if (regp && regp->start && 0 <= i && i <= regp->rx.re_nsub) if (!regp->done && regp->matches[i].rm_eo >= 0) return regp->start+regp->matches[i].rm_eo-regp->s; else return -1; else return -1; } static char *reg_str(int i) { if (regp && regp->start && 0 <= i && i <= regp->rx.re_nsub) if (!regp->done && regp->matches[i].rm_so >= 0) return regp->start+regp->matches[i].rm_so; else return NULL; else return NULL; } /* interface functions */ FUNCTION(clib,regmatch,argc,argv) { char *opts, *regex, *s; int cflags = 0, eflags = 0, global = 0, ret; if (argc != 3 || !isstr(argv[0], &opts) || !isstr(argv[1], ®ex) || !isstr(argv[2], &s)) return __FAIL; while (*opts) switch (*(opts++)) { case 'g': if (!global) global = 1; break; case 'G': global = 2; break; case 'i': cflags |= REG_ICASE; break; case 'n': cflags |= REG_NEWLINE; break; case '^': eflags |= REG_NOTBOL; break; case '$': eflags |= REG_NOTEOL; break; default: return __FAIL; } ret = reg_add(regex, s, global, cflags, eflags); if (ret == -1) return __ERROR; else if (ret) return mkapp(mksym(sym(regerr)), mkstr(strdup(regmsg))); ret = reg_search(); if (ret == -1 || ret == REG_NOMATCH) return mkfalse; else if (ret) return mkapp(mksym(sym(regerr)), mkstr(strdup(regmsg))); else return mktrue; } FUNCTION(clib,regnext,argc,argv) { int ret; if (argc != 0) return __FAIL; ret = reg_search(); if (ret == -1 || ret == REG_NOMATCH) return mkfalse; else if (ret) return mkapp(mksym(sym(regerr)), mkstr(strdup(regmsg))); else return mktrue; } FUNCTION(clib,regdone,argc,argv) { if (argc != 0) return __FAIL; reg_done(); return mkvoid; } FUNCTION(clib,regstart,argc,argv) { long start; if (argc != 0) return __FAIL; start = reg_start(); if (start >= 0) return mkint(start); else return __FAIL; } FUNCTION(clib,regskip,argc,argv) { char *skip; if (argc != 0) return __FAIL; if ((skip = reg_skipstr())) { long start = reg_start(), pos = reg_pos(0); char *s; if (pos >= start) s = malloc(pos-start+1); else s = malloc(strlen(skip)+1); if (!s) return __ERROR; if (pos >= start) { strncpy(s, skip, pos-start); s[pos-start] = 0; } else strcpy(s, skip); return mkstr(s); } else return __FAIL; } FUNCTION(clib,reg,argc,argv) { long i; if (argc != 1 || !isint(argv[0], &i) || i < 0 || i > reg_nmatches()) return __FAIL; if (reg_start() >= 0) { long pos = reg_pos(i), end = reg_end(i); char *s; if (pos < 0 || end < 0) s = strdup(""); else if (!(s = malloc(end-pos+1))) return __ERROR; else { strncpy(s, reg_str(i), end-pos); s[end-pos] = 0; } return mkstr(s); } else return __FAIL; } FUNCTION(clib,regpos,argc,argv) { long i; if (argc != 1 || !isint(argv[0], &i) || i < 0 || i > reg_nmatches()) return __FAIL; if (reg_start() >= 0) return mkint(reg_pos(i)); else return __FAIL; } FUNCTION(clib,regend,argc,argv) { long i; if (argc != 1 || !isint(argv[0], &i) || i < 0 || i > reg_nmatches()) return __FAIL; if (reg_start() >= 0) return mkint(reg_end(i)); else return __FAIL; } FUNCTION(clib,regs,argc,argv) { expr x; size_t i; if (argc != 0) return __FAIL; x = mknil; i = reg_nmatches(); while (x && i > 0) { if (reg_pos(i) >= 0 && reg_end(i) >= 0) x = mkcons(mkint(i), x); i--; } if (x) return x; else return __ERROR; } /* additional integer functions: ******************************************/ FUNCTION(clib,pow,argc,argv) { mpz_t m, u; unsigned long n; if (argc != 2 || !ismpz(argv[0], m) || !isuint(argv[1], &n) || n > 0 && mpz_size(m) > INT_MAX/n) return __FAIL; if (!mpz_new(u, n*mpz_size(m))) return __ERROR; mpz_pow_ui(u, m, n); if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,root,argc,argv) { mpz_t m, u; unsigned long n; if (argc != 2 || !ismpz(argv[0], m) || !isuint(argv[1], &n) || n == 0 || mpz_sgn(m) == -1 && (n&1) == 0) return __FAIL; if (!mpz_new(u, mpz_size(m)/n+1)) return __ERROR; mpz_root(u, m, n); if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,intsqrt,argc,argv) { mpz_t m, u; if (argc != 1 || !ismpz(argv[0], m) || mpz_sgn(m) < 0) return __FAIL; if (!mpz_new(u, (mpz_size(m)>>2)+1)) return __ERROR; mpz_sqrt(u, m); if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,powmod,argc,argv) { mpz_t k, k2, m, n, u; int sgn; if (argc != 3 || !ismpz(argv[0], k) || !ismpz(argv[1], m) || !ismpz(argv[2], n) || mpz_sgn(n) < 0 || mpz_sgn(k) == 0) return __FAIL; if (!mpz_new(u, mpz_size(k))) return __ERROR; sgn = mpz_sgn(k); if (!mpz_copy(k2, k)) { mpz_clear(u); return __ERROR; } if (sgn < 0) k2->_mp_size = -k2->_mp_size; mpz_powm(u, m, n, k2); mpz_clear(k2); if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,invmod,argc,argv) { mpz_t k, m, u; if (argc != 2 || !ismpz(argv[0], k) || !ismpz(argv[1], m) || mpz_sgn(k) == 0) return __FAIL; if (!mpz_new(u, mpz_size(k))) return __ERROR; if (!mpz_invert(u, m, k)) { mpz_clear(u); return __FAIL; } if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,isprime,argc,argv) { static long rep = 0; mpz_t n; int ret; if (argc != 1 || !ismpz(argv[0], n)) return __FAIL; if (!rep) { /* get this value only once when we're first invoked, to avoid the overhead in subsequent calls */ expr x = eval(mksym(sym(ISPRIME_REP))); if (x) { if (!isint(x, &rep) || rep <= 0) rep = 5; dispose(x); } else rep = 5; } ret = mpz_probab_prime_p(n, rep); if (ret == 2) return mktrue; else if (ret == 0) return mkfalse; else return __FAIL; } FUNCTION(clib,gcd,argc,argv) { mpz_t m, n, u; if (argc != 2 || !ismpz(argv[0], m) || !ismpz(argv[1], n) || mpz_sgn(m) == 0 && mpz_sgn(n) == 0) return __FAIL; if (!mpz_new(u, long_min(mpz_size(m),mpz_size(n)))) return __ERROR; mpz_gcd(u, m, n); if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,lcm,argc,argv) { mpz_t m, n, u; if (argc != 2 || !ismpz(argv[0], m) || !ismpz(argv[1], n) || mpz_sgn(m) == 0 || mpz_sgn(n) == 0 || mpz_size(m)+mpz_size(n) < 0) return __FAIL; if (!mpz_new(u, mpz_size(m)+mpz_size(n))) return __ERROR; mpz_lcm(u, m, n); if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,fact,argc,argv) { mpz_t m, n, u; unsigned long ret; long k; if (argc != 2 || !ismpz(argv[0], m) || !ismpz(argv[1], n) || mpz_sgn(m) == 0 || mpz_sgn(n) <= 0 || isint(argv[1], &k) && k == 1) return __FAIL; if (!mpz_new(u, mpz_size(m))) return __ERROR; ret = mpz_remove(u, m, n); mpz_clear(u); return mkuint(ret); } FUNCTION(clib,rem,argc,argv) { mpz_t m, n, u; long k; if (argc != 2 || !ismpz(argv[0], m) || !ismpz(argv[1], n) || mpz_sgn(m) == 0 || mpz_sgn(n) <= 0 || isint(argv[1], &k) && k == 1) return __FAIL; if (!mpz_new(u, mpz_size(m))) return __ERROR; mpz_remove(u, m, n); if (!mpz_actsize(u)) return __ERROR; return mkmpz(u); } FUNCTION(clib,jacobi,argc,argv) { mpz_t m, n; int ret; if (argc != 2 || !ismpz(argv[0], m) || !ismpz(argv[1], n) || mpz_sgn(n) <= 0) return __FAIL; ret = mpz_jacobi(m, n); return mkint(ret); } /* C replacements of common stdlib functions: *****************************/ /* Note: In difference to our usual philosophy to make an operation __FAIL if certain implementation limits are exceeded, the following operations return an __ERROR in such cases. This is done whenever the operation, if __FAILed, would certainly cause some stack or memory overflow later, so we might as well abort it right here. */ FUNCTION(clib,append,argc,argv) { if (argc == 2) { int i, n = 0; expr x, *xs, *ys, hd, tl; if (isvoid(argv[0]) || istuple(argv[0], &n, &xs)) { if (!(ys = malloc((n+1)*sizeof(expr)))) return __ERROR; for (i = 0; i < n; i++) ys[i] = xs[i]; ys[i++] = argv[1]; return mktuplev(n+1, ys); } else { for (n = 0, x = argv[0]; iscons(x, &hd, &tl); n++) if (n >= INT_MAX/sizeof(expr)-1) return __ERROR; else x = tl; if (!isnil(x)) return __FAIL; else if (!(ys = malloc((n+1)*sizeof(expr)))) return __ERROR; for (n = 0, x = argv[0]; iscons(x, &hd, &tl); n++) { ys[n] = hd; x = tl; } ys[n++] = argv[1]; return mklistv(n, ys); } } else return __FAIL; } FUNCTION(clib,cat,argc,argv) { expr *xs, x, y, hd, tl, hd1, tl1; int n; if (argc != 1) return __FAIL; for (n = 0, x = argv[0]; iscons(x, &hd, &tl); x = tl) { for (y = hd; iscons(y, &hd1, &tl1); y = tl1) if (n >= INT_MAX/sizeof(expr)) return __ERROR; else n++; if (!isnil(y)) return __FAIL; } if (!isnil(x)) return __FAIL; if (!(xs = malloc(n*sizeof(expr)))) return __ERROR; for (n = 0, x = argv[0]; iscons(x, &hd, &tl); x = tl) for (y = hd; iscons(y, &hd1, &tl1); y = tl1) xs[n++] = hd1; return mklistv(n, xs); } FUNCTION(clib,mklist,argc,argv) { long n; if (argc == 2 && isint(argv[1], &n)) { expr x = argv[0], y = mknil; while (y && n-- > 0) y = mkcons(x, y); if (!y) return __ERROR; else return y; } else return __FAIL; } FUNCTION(clib,nums,argc,argv) { mpz_t n, m, u; double f, g; long len, i, j; expr *xs; unsigned char n_is_mpz, m_is_mpz; if (argc != 2 || !((n_is_mpz = ismpz(argv[0], n)) || isfloat(argv[0], &f)) || !((m_is_mpz = ismpz(argv[1], m)) || isfloat(argv[1], &g))) return __FAIL; if (n_is_mpz) { if (!m_is_mpz && !mpz_from_double(m, g)) return __ERROR; if (mpz_cmp(n, m) > 0) return mknil; if (!mpz_addop2(mpz_sub, u, m, n)) return __ERROR; if (!my_mpz_fits_slong_p(u)) { mpz_clear(u); return __ERROR; } len = mpz_get_si(u)+1; mpz_clear(u); if (len <= 0 || len > INT_MAX/sizeof(expr)) return __ERROR; if (!(xs = malloc(len*sizeof(expr)))) return __ERROR; if (!mpz_copy(u, n)) return __ERROR; i = 0; while (mpz_cmp(u, m) <= 0) { mpz_t v; if (!(xs[i++] = mkmpz(u))) { for (j = 0; j < i-1; j++) dispose(xs[j]); free(xs); return __ERROR; } if (!mpz_addop1(mpz_add_ui, v, u, 1U)) { for (j = 0; j < i; j++) dispose(xs[j]); free(xs); mpz_clear(u); return __ERROR; } memcpy(u, v, sizeof(mpz_t)); } } else { double ip; if (m_is_mpz) g = mpz_get_d(m); if (g < f) return mknil; modf(g-f, &ip); if (ip >= (double)INT_MAX) return __ERROR; /* add 1 to be safe (will be corrected later) */ len = ((int)ip)+2; if (len <= 0 || len > INT_MAX/sizeof(expr)) return __ERROR; if (!(xs = malloc(len*sizeof(expr)))) return __ERROR; i = 0; while (f <= g) { if (!(xs[i++] = mkfloat(f))) { for (j = 0; j < i-1; j++) dispose(xs[j]); free(xs); return __ERROR; } f += 1.0; } if (i < len) len = i; } return mklistv(len, xs); } FUNCTION(clib,numsby,argc,argv) { mpz_t n, m, k, u; double f, g, h; long len, i, j; expr *xs; unsigned char k_is_mpz, n_is_mpz, m_is_mpz; if (argc != 3 || !((k_is_mpz = ismpz(argv[0], k)) || isfloat(argv[0], &h)) || !((n_is_mpz = ismpz(argv[1], n)) || isfloat(argv[1], &f)) || !((m_is_mpz = ismpz(argv[2], m)) || isfloat(argv[2], &g))) return __FAIL; if (n_is_mpz && k_is_mpz) { int sgn = mpz_sgn(k); if (sgn == 0) return __FAIL; if (!m_is_mpz && !mpz_from_double(m, g)) return __ERROR; if (mpz_cmp(n, m)*sgn > 0) return mknil; if (!mpz_addop2(mpz_sub, u, m, n)) return __ERROR; /* this one shouldn't fail */ mpz_tdiv_q(u, u, k); if (!my_mpz_fits_slong_p(u)) { mpz_clear(u); return __ERROR; } len = mpz_get_si(u)+1; mpz_clear(u); if (len <= 0 || len > INT_MAX/sizeof(expr)) return __ERROR; if (!(xs = malloc(len*sizeof(expr)))) return __ERROR; if (!mpz_copy(u, n)) return __ERROR; i = 0; while (sgn*mpz_cmp(u, m) <= 0) { mpz_t v; if (!(xs[i++] = mkmpz(u))) { for (j = 0; j < i-1; j++) dispose(xs[j]); free(xs); return __ERROR; } if (!mpz_addop2(mpz_add, v, u, k)) { for (j = 0; j < i; j++) dispose(xs[j]); free(xs); mpz_clear(u); return __ERROR; } memcpy(u, v, sizeof(mpz_t)); } } else { double ip, sgn; if (k_is_mpz) h = mpz_get_d(k); if (n_is_mpz) f = mpz_get_d(n); if (m_is_mpz) g = mpz_get_d(m); sgn = (h<0.0)?-1.0:(h>0.0)?1.0:0.0; if (sgn == 0.0) return __FAIL; if ((f-g)*sgn > 0.0) return mknil; modf((g-f)/h, &ip); if (ip >= (double)INT_MAX) return __ERROR; len = ((int)ip)+2; if (len <= 0 || len > INT_MAX/sizeof(expr)) return __ERROR; if (!(xs = malloc(len*sizeof(expr)))) return __ERROR; i = 0; while (sgn*(f-g) <= 0) { if (!(xs[i++] = mkfloat(f))) { for (j = 0; j < i-1; j++) dispose(xs[j]); free(xs); return __ERROR; } f += h; } if (i < len) len = i; } return mklistv(len, xs); } FUNCTION(clib,reverse,argc,argv) { if (argc == 1) { expr x = argv[0], y = mknil, hd, tl; while (y && iscons(x, &hd, &tl)) { expr z = mkcons(hd, y); y = z; x = tl; } if (!y) return __ERROR; else if (isnil(x)) return y; else { dispose(y); return __FAIL; } } else return __FAIL; } FUNCTION(clib,tuplecat,argc,argv) { expr *xs, *ys, x, hd, tl; int n, l; if (argc != 1) return __FAIL; for (n = 0, x = argv[0]; iscons(x, &hd, &tl); x = tl) { if (istuple(hd, &l, &ys)) if (l < 0 || n > INT_MAX/sizeof(expr)-l) return __ERROR; else n += l; else return __FAIL; } if (!isnil(x)) return __FAIL; if (!(xs = malloc(n*sizeof(expr)))) return __ERROR; for (n = 0, x = argv[0]; iscons(x, &hd, &tl); x = tl) if (istuple(hd, &l, &ys) & l > 0) { memcpy(xs+n, ys, l*sizeof(expr)); n += l; } return mktuplev(n, xs); } FUNCTION(clib,chars,argc,argv) { char *s; if (argc == 1 && isstr(argv[0], &s)) { int l = strlen(s); if (l < 0 || l > INT_MAX/sizeof(expr)) return __ERROR; else if (l == 0) return mknil; else { expr *xs = malloc(l*sizeof(expr)); if (xs) { int i = 0, j; while(*s) { char *t = malloc(2*sizeof(char)); if (t) { t[0] = *(s++); t[1] = 0; if (!(xs[i] = mkstr(t))) goto errexit; else i++; } else goto errexit; } return mklistv(l, xs); errexit: for (j = 0; j < i; j++) dispose(xs[j]); free(xs); return __ERROR; } else return __ERROR; } } else return __FAIL; } FUNCTION(clib,join,argc,argv) { expr x, hd, tl; char *s, *t, *delim; int n, l, k, init; if (argc != 2 || !isstr(argv[0], &delim)) return __FAIL; k = strlen(delim); for (init = n = 0, x = argv[1]; iscons(x, &hd, &tl); x = tl) { if (isstr(hd, &s)) { l = strlen(s); if (n > 0) { if (l < 0 || l >= INT_MAX-k) return __ERROR; l += k; } if (l < 0 || n >= INT_MAX-l) return __ERROR; else n += l; init = 1; } else return __FAIL; } if (!isnil(x)) return __FAIL; if (!(t = malloc(n+1))) return __ERROR; *t = 0; for (init = n = 0, x = argv[1]; iscons(x, &hd, &tl); x = tl) if (isstr(hd, &s)) { if (init) { strcpy(t+n, delim); n += k; } strcpy(t+n, s); n += strlen(s); init = 1; } return mkstr(t); } /* This is essentially the same algorithm as in string.q, but implemented in C for greater efficiency. */ FUNCTION(clib,split,argc,argv) { char *s, *t, *delim; expr *xs; int n, l, i, j; if (argc == 2 && isstr(argv[0], &delim) && isstr(argv[1], &s)) { l = strlen(s); if (l < 0) return __FAIL; else if (l == 0) return mknil; i = j = n = 0; while (i < l) { if (j < l && !strchr(delim, s[j])) j++; else { n++; if (j == l-1) { /* trailing delimiter */ n++; break; } else i = ++j; } } if (n > INT_MAX/sizeof(expr)) return __ERROR; if (!(xs = malloc(n*sizeof(expr)))) return __ERROR; i = j = n = 0; while (i < l) { if (j < l && !strchr(delim, s[j])) j++; else { if (!(t = malloc(j-i+1))) goto errexit; strncpy(t, s+i, j-i); t[j-i] = 0; if (!(xs[n] = mkstr(t))) goto errexit; n++; if (j == l-1) { /* trailing delimiter */ if (!(t = malloc(1))) goto errexit; *t = 0; if (!(xs[n] = mkstr(t))) goto errexit; n++; break; } else i = ++j; } } return mklistv(n, xs); errexit: for (i = 0; i < n; i++) dispose(xs[i]); free(xs); return __ERROR; } else return __FAIL; } FUNCTION(clib,strcat,argc,argv) { expr x, hd, tl; char *s, *t; int n, l; if (argc != 1) return __FAIL; for (n = 0, x = argv[0]; iscons(x, &hd, &tl); x = tl) { if (isstr(hd, &s)) { l = strlen(s); if (l < 0 || n >= INT_MAX-l) return __ERROR; else n += l; } else return __FAIL; } if (!isnil(x)) return __FAIL; if (!(t = malloc(n+1))) return __ERROR; *t = 0; for (n = 0, x = argv[0]; iscons(x, &hd, &tl); x = tl) if (isstr(hd, &s)) { strcpy(t+n, s); n += strlen(s); } return mkstr(t); } static expr pred; static int err; static int eval_pred(const void *x, const void *y) { expr t = mkapp(mkapp(pred, *((expr*)x)), *((expr*)y)), p; if (t && (p = eval(t))) { int ret; if (istrue(p)) ret = 1; else if (isfalse(p)) ret = 0; else { /* values are incomparable */ err = 1; ret = 0; } return ret; } else { /* fatal error */ err = -1; return 0; } } static int cmp_p(const void *x, const void *y) { if (err) return 0; else if (eval_pred(x, y)) return -1; else if (err) return 0; else if (eval_pred(y, x)) return 1; else return 0; } FUNCTION(clib,sort,argc,argv) { if (argc == 2) { expr *xs, p = argv[0], x, hd, tl; int n; for (n = 0, x = argv[1]; iscons(x, &hd, &tl); x = tl) { if (n >= INT_MAX/sizeof(expr)) return __ERROR; else n++; } if (!isnil(x)) return __FAIL; if (!(xs = malloc(n*sizeof(expr)))) return __ERROR; for (n = 0, x = argv[1]; iscons(x, &hd, &tl); x = tl) xs[n++] = hd; err = 0; pred = p; qsort(xs, n, sizeof(expr), cmp_p); if (err) { free(xs); return (err==-1)?__ERROR:__FAIL; } else return mklistv(n, xs); } else return __FAIL; } #ifdef USE_THREADS /* do necessary cleanup at fork time */ static void atfork_child(void) { THREAD *thr, *this = thr0+this_thread(); for (thr = thr0; thr <= thr0+maxused; thr++) if (thr->used) { pthread_mutex_init(&thr->exit_mutex, NULL); pthread_cond_init(&thr->exit_cond, NULL); if (thr == this) thr->id = pthread_self(); else { /* XXX FIXME: experimental stuff here. Second attempt to prevent waiting for dead child threads in thread destructor (see also ChangeLog entry from 2002-08-29). */ #if 0 thr->active = 0; thr->canceled = 1; #else /* this thread does not exist in the child any more, so we collect its resources */ thr->active = thr->canceled = thr->used = 0; if (thr->arg) { freeref(thr->arg); thr->arg = NULL; } if (thr->result) { freeref(thr->result); thr->result = NULL; } if (thr->thread) thr->thread = NULL; #endif } } stamp++; #ifdef DEBUG printf("thread %d (id %d) forked\n", this-thr0, (int)this->id); #endif } #endif INIT(clib) { #ifdef WIN32 WORD wVersionRequested = MAKEWORD(2, 0); WSADATA wsaData; WSAStartup(wVersionRequested, &wsaData); #endif tzset(); thr0->active = 1; thr0->canceled = 0; thr0->used = 1; thr0->result = NULL; maxused = 0; #ifdef USE_THREADS thr0->id = pthread_self(); #ifdef WIN32 thr0->handle = GetCurrentThread(); DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(), &thr0->handle, 0, FALSE, DUPLICATE_SAME_ACCESS); thr0->pol = 0; #endif pthread_mutex_init(&thr0->exit_mutex, NULL); pthread_cond_init(&thr0->exit_cond, NULL); pthread_mutex_init(&format_mutex, NULL); thread_atfork(NULL, NULL, atfork_child); #ifdef __linux__ { FILE *fp; const char * givertcap = getenv("GIVERTCAP"); if(!givertcap) givertcap = "/usr/local/bin/givertcap"; if ((fp = fopen(givertcap, "r"))) { fclose(fp); system(givertcap); } } #endif #endif } FINI(clib) { #ifdef WIN32 WSACleanup(); #endif #ifndef __MINGW32__ /* clean up zombies */ int pid, status, serrno; serrno = errno; while (1) { pid = waitpid (-1, &status, WNOHANG); if (pid <= 0) break; } errno = serrno; #endif }