/* 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 <stdio.h>
#include <ctype.h>
#include <signal.h>
#include <math.h>
#ifdef HAVE_ERRNO_H
#include <errno.h>
#else
# ifndef errno
extern int errno;
# endif
#endif
#include <sys/stat.h>
/* check for standard C headers */
#if STDC_HEADERS
# include <stdlib.h>
# include <string.h>
#else
# ifndef HAVE_STRCHR
# define strchr index
# define strrchr rindex
# endif
char *strchr (), *strrchr ();
#endif
#ifdef HAVE_MALLOC_H
#include <stdlib.h>
#endif
#ifdef HAVE_LIMITS_H
#include <limits.h>
#endif
#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
# if HAVE_SYS_TIME_H
# include <sys/time.h>
# else
# include <time.h>
# endif
#endif
#include <sys/types.h>
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
#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 <dirent.h>
# define NAMLEN(dirent) strlen((dirent)->d_name)
#else
# define dirent direct
# define NAMLEN(dirent) (dirent)->d_namlen
# if HAVE_SYS_NDIR_H
# include <sys/ndir.h>
# endif
# if HAVE_SYS_DIR_H
# include <sys/dir.h>
# endif
# if HAVE_NDIR_H
# include <ndir.h>
# endif
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_PWD_H
#include <pwd.h>
#endif
#ifdef HAVE_GRP_H
#include <grp.h>
#endif
#ifdef HAVE_FCNTL_H
#include <fcntl.h>
#endif
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
#endif
#ifdef HAVE_TERMIOS_H
#include <termios.h>
#endif
#ifdef HAVE_PTY_H
#include <pty.h>
#else
#ifdef HAVE_UTIL_H
#include <util.h>
#endif
#endif
#ifdef HAVE_SYS_IOCTL_H
#include <sys/ioctl.h>
#endif
#ifdef HAVE_STROPTS_H
#include <stropts.h>
#endif
#ifdef HAVE_SYS_SOCKET_H
#include <sys/socket.h>
#ifdef HAVE_SYS_UN_H
#include <sys/un.h>
#endif
#include <netinet/in.h>
#ifdef HAVE_ARPA_INET_H
#include <arpa/inet.h>
#endif
#endif
#ifdef HAVE_NETDB_H
#include <netdb.h>
#endif
#ifdef HAVE_UTIME_H
#include <utime.h>
#endif
#ifdef HAVE_SYS_UTSNAME_H
#include <sys/utsname.h>
#endif
#ifdef HAVE_SYS_TIMES_H
#include <sys/times.h>
#endif
#ifdef USE_THREADS
#ifdef HAVE_SCHED_H
#include <sched.h>
#endif
#include <pthread.h>
#include <semaphore.h>
#endif
#if defined(HAVE_SYS_SOCKET_H) || defined(WIN32)
#define HAVE_BSD_SOCKETS 1
#endif
#ifdef WIN32
#include <windows.h>
#include <process.h>
#include <io.h>
#include <fcntl.h>
#include <sys/utime.h>
#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 <gmp.h>
#include <libq.h>
/* 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 <dmalloc.h>
#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
}
syntax highlighted by Code2HTML, v. 0.9.1