old swi library: replace by original yap code

library/dialect/swi/os/SWI-Stream.h

@@ -0,0 +1,353 @@
+
+#ifndef _PL_STREAM_H
+#define _PL_STREAM_H
+
+#ifndef _PL_EXPORT_DONE
+#define _PL_EXPORT_DONE
+
+#if (defined(__WINDOWS__) || defined(__CYGWIN__)) && !defined(__LCC__)
+#define HAVE_DECLSPEC
+#endif
+
+#ifdef HAVE_DECLSPEC
+# ifdef PL_KERNEL
+#define PL_EXPORT(type)		__declspec(dllexport) type
+#define PL_EXPORT_DATA(type)	__declspec(dllexport) type
+#define install_t	 	void
+# else
+#  ifdef __BORLANDC__
+#define PL_EXPORT(type)	 	type _stdcall
+#define PL_EXPORT_DATA(type)	extern type
+#  else
+#define PL_EXPORT(type)	 	extern type
+#define PL_EXPORT_DATA(type)	__declspec(dllimport) type
+#  endif
+#define install_t	 	__declspec(dllexport) void
+# endif
+#else /*HAVE_DECLSPEC*/
+#define PL_EXPORT(type)	 	extern type
+#define PL_EXPORT_DATA(type)	extern type
+#define install_t	 	void
+#endif /*HAVE_DECLSPEC*/
+#endif /*_PL_EXPORT_DONE*/
+
+/* This appears to make the wide-character support compile and work
+   on HPUX 11.23.  There really should be a cleaner way ...
+*/
+#if defined(__hpux)
+#include <sys/_mbstate_t.h>
+#endif
+
+#if defined(_MSC_VER) && !defined(__WINDOWS__)
+#define __WINDOWS__ 1
+#endif
+
+#include <stdarg.h>
+#include <wchar.h>
+#include <stddef.h>
+#ifdef __WINDOWS__
+#include <stdint.h>
+#ifndef INT64_T_DEFINED
+#define INT64_T_DEFINED 1
+typedef __int64 int64_t;
+typedef unsigned __int64 uint64_t;
+#endif
+#else
+#include <unistd.h>
+#include <inttypes.h>			/* more portable than stdint.h */
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef PL_HAVE_TERM_T
+#define PL_HAVE_TERM_T
+typedef	intptr_t    term_t;
+#endif
+		 /*******************************
+		 *	    CONSTANTS		*
+		 *******************************/
+
+#ifndef EOF
+#define EOF (-1)
+#endif
+
+#ifndef NULL
+#define NULL ((void *)0)
+#endif
+
+#if defined(__WINDOWS__) && !defined(EWOULDBLOCK)
+#define EWOULDBLOCK	1000		/* Needed for socket handling */
+#endif
+#define EPLEXCEPTION	1001		/* errno: pending Prolog exception */
+
+#define SIO_BUFSIZE	(4096)		/* buffering buffer-size */
+#define SIO_LINESIZE	(1024)		/* Sgets() default buffer size */
+#define SIO_MAGIC	(7212676)	/* magic number */
+#define SIO_CMAGIC	(42)		/* we are close (and thus illegal!) */
+
+typedef ssize_t (*Sread_function)(void *handle, char *buf, size_t bufsize);
+typedef ssize_t (*Swrite_function)(void *handle, char*buf, size_t bufsize);
+typedef long  (*Sseek_function)(void *handle, long pos, int whence);
+typedef int64_t (*Sseek64_function)(void *handle, int64_t pos, int whence);
+typedef int   (*Sclose_function)(void *handle);
+typedef int   (*Scontrol_function)(void *handle, int action, void *arg);
+
+#include "pl-thread.h"
+
+typedef struct io_functions
+{ Sread_function	read;		/* fill the buffer */
+  Swrite_function	write;		/* empty the buffer */
+  Sseek_function	seek;		/* seek to position */
+  Sclose_function	close;		/* close stream */
+  Scontrol_function	control;	/* Info/control */
+  Sseek64_function	seek64;		/* seek to position (intptr_t files) */
+} IOFUNCTIONS;
+
+typedef struct io_position
+{ int64_t		byteno;		/* byte-position in file */
+  int64_t		charno;		/* character position in file */
+  long int		lineno;		/* lineno in file */
+  long int		linepos;	        /* position in line */
+  intptr_t		reserved[2];	/* future extensions */
+} IOPOS;
+
+#if defined(YAP_H)
+  typedef encoding_t IOENC;
+#else
+					/* NOTE: check with encoding_names */
+					/* in pl-file.c */
+typedef enum
+{ ENC_UNKNOWN = 0,			/* invalid/unknown */
+  ENC_OCTET,				/* raw 8 bit input */
+  ENC_ASCII,				/* US-ASCII (0..127) */
+  ENC_ISO_LATIN_1,			/* ISO Latin-1 (0..256) */
+  ENC_ANSI,				/* default (multibyte) codepage */
+  ENC_UTF8,
+  ENC_UNICODE_BE,			/* big endian unicode file */
+  ENC_UNICODE_LE,			/* little endian unicode file */
+  ENC_WCHAR				/* pl_wchar_t */
+} IOENC;
+#endif
+
+#define SIO_NL_POSIX  0			/* newline as \n */
+#define SIO_NL_DOS    1			/* newline as \r\n */
+#define SIO_NL_DETECT 3			/* detect processing mode */
+
+typedef struct io_stream
+{ char		       *bufp;		/* `here' */
+  char		       *limitp;		/* read/write limit */
+  char		       *buffer;		/* the buffer */
+  char		       *unbuffer;	/* Sungetc buffer */
+  int			lastc;		/* last character written */
+  int			magic;		/* magic number SIO_MAGIC */
+  int  			bufsize;	/* size of the buffer */
+  int			flags;		/* Status flags */
+  IOPOS			posbuf;		/* location in file */
+  IOPOS *		position;	/* pointer to above */
+  void		       *handle;		/* function's handle */
+  IOFUNCTIONS	       *functions;	/* open/close/read/write/seek */
+  int		        locks;		/* lock/unlock count */
+  IOLOCK *		mutex;		/* stream mutex */
+					/* SWI-Prolog 4.0.7 */
+  void			(*close_hook)(void* closure);
+  void *		closure;
+					/* SWI-Prolog 5.1.3 */
+  int			timeout;	/* timeout (milliseconds) */
+					/* SWI-Prolog 5.4.4 */
+  char *		message;	/* error/warning message */
+  IOENC			encoding;	/* character encoding used */
+  struct io_stream *	tee;		/* copy data to this stream */
+  mbstate_t *		mbstate;	/* ENC_ANSI decoding */
+  struct io_stream *	upstream;	/* stream providing our input */
+  struct io_stream *	downstream;	/* stream providing our output */
+  unsigned		newline : 2;	/* Newline mode */
+  unsigned		erased : 1;	/* Stream was erased */
+  unsigned		references : 4;	/* Reference-count */
+  int			io_errno;	/* Save errno value */
+  void *		exception;	/* pending exception (record_t) */
+  void *		context;	/* getStreamContext() */
+  intptr_t		reserved[0];	/* reserved for extension */
+  struct PL_locale *    locale;         /* Locale associated to stream */
+#if 0 /* We used them all :-( */
+  intptr_t              reserved[0];    /* reserved for extension */
+#endif
+} IOSTREAM;
+
+#define SmakeFlag(n)	(1<<(n-1))
+
+#define SIO_FBUF	SmakeFlag(1)	/* full buffering */
+#define SIO_LBUF	SmakeFlag(2)	/* line buffering */
+#define SIO_NBUF	SmakeFlag(3)	/* no buffering */
+#define SIO_FEOF	SmakeFlag(4)	/* end-of-file */
+#define SIO_FERR	SmakeFlag(5)	/* error ocurred */
+#define SIO_USERBUF	SmakeFlag(6)	/* buffer is from user */
+#define SIO_INPUT	SmakeFlag(7)	/* input stream */
+#define SIO_OUTPUT	SmakeFlag(8)	/* output stream */
+#define SIO_NOLINENO	SmakeFlag(9)	/* line no. info is void */
+#define SIO_NOLINEPOS	SmakeFlag(10)	/* line pos is void */
+#define SIO_STATIC	SmakeFlag(11)	/* Stream in static memory */
+#define SIO_RECORDPOS	SmakeFlag(12)	/* Maintain position */
+#define SIO_FILE	SmakeFlag(13)	/* Stream refers to an OS file */
+#define SIO_PIPE	SmakeFlag(14)	/* Stream refers to an OS pipe */
+#define SIO_NOFEOF	SmakeFlag(15)	/* don't set SIO_FEOF flag */
+#define SIO_TEXT	SmakeFlag(16)	/* text-mode operation */
+#define SIO_FEOF2	SmakeFlag(17)	/* attempt to read past eof */
+#define SIO_FEOF2ERR	SmakeFlag(18)	/* Sfpasteof() */
+#define SIO_NOCLOSE     SmakeFlag(19)	/* Do not close on abort */
+#define SIO_APPEND	SmakeFlag(20)	/* opened in append-mode */
+#define SIO_UPDATE	SmakeFlag(21)	/* opened in update-mode */
+#define SIO_ISATTY	SmakeFlag(22)	/* Stream is a tty */
+#define SIO_CLOSING	SmakeFlag(23)	/* We are closing the stream */
+#define SIO_TIMEOUT	SmakeFlag(24)	/* We had a timeout */
+#define SIO_NOMUTEX	SmakeFlag(25)	/* Do not allow multi-thread access */
+#define SIO_ADVLOCK	SmakeFlag(26)	/* File locked with advisory lock */
+#define SIO_WARN	SmakeFlag(27)	/* Pending warning */
+#define SIO_CLEARERR	SmakeFlag(28)	/* Clear error after reporting */
+#define SIO_REPXML	SmakeFlag(29)	/* Bad char --> XML entity */
+#define SIO_REPPL	SmakeFlag(30)	/* Bad char --> Prolog \hex\ */
+#define SIO_BOM		SmakeFlag(31)	/* BOM was detected/written */
+
+#define	SIO_SEEK_SET	0	/* From beginning of file.  */
+#define	SIO_SEEK_CUR	1	/* From current position.  */
+#define	SIO_SEEK_END	2	/* From end of file.  */
+
+PL_EXPORT(IOSTREAM *)	S__getiob(void);	/* get DLL's __iob[] address */
+
+PL_EXPORT_DATA(IOFUNCTIONS)  Sfilefunctions;	/* OS file functions */
+PL_EXPORT_DATA(int)	     Slinesize;		/* Sgets() linesize */
+#if (defined(__CYGWIN__) || defined(__MINGW32__)) && !defined(PL_KERNEL)
+#define S__iob S__getiob()
+#else
+PL_EXPORT_DATA(IOSTREAM)    S__iob[3];		/* Libs standard streams */
+#endif
+
+#define Sinput  (&S__iob[0])		/* Stream Sinput */
+#define Soutput (&S__iob[1])		/* Stream Soutput */
+#define Serror  (&S__iob[2])		/* Stream Serror */
+
+#define Sgetchar()	Sgetc(Sinput)
+#define Sputchar(c)	Sputc((c), Soutput)
+
+static inline void
+S__checkpasteeof(IOSTREAM *s, int c)
+{
+  if ( (c)==-1 && ((s)->flags & (SIO_FEOF|SIO_FERR)) )
+    ((s)->flags |= SIO_FEOF2);
+}
+
+#define S__updatefilepos_getc(s, c) \
+	((s)->position ? S__fupdatefilepos_getc((s), (c)) \
+		       : S__fcheckpasteeof((s), (c)))
+
+#define Snpgetc(s) ((s)->bufp < (s)->limitp ? (int)(*(s)->bufp++)&0xff \
+					    : S__fillbuf(s))
+#define Sgetc(s) S__updatefilepos_getc((s), Snpgetc(s))
+
+PL_EXPORT(int)		Speekcode(IOSTREAM *s);
+
+/* Control-operations */
+#define SIO_GETSIZE	(1)		/* get size of underlying object */
+#define SIO_GETFILENO	(2)		/* get underlying file (if any) */
+#define SIO_SETENCODING	(3)		/* modify encoding of stream */
+#define SIO_FLUSHOUTPUT	(4)		/* flush output */
+#define SIO_LASTERROR	(5)		/* string holding last error */
+#ifdef __WINDOWS__
+#define SIO_GETWINSOCK  (6)             /* get underlying SOCKET object */
+#endif
+
+/* Sread_pending() */
+#define SIO_RP_BLOCK 0x1		/* wait for new input */
+
+#if IOSTREAM_REPLACES_STDIO
+
+#undef FILE
+#undef stdin
+#undef stdout
+#undef stderr
+#undef putc
+#undef getc
+#undef putchar
+#undef getchar
+#undef feof
+#undef ferror
+#undef fileno
+#undef clearerr
+
+#define FILE		IOSTREAM
+#define stdin		Sinput
+#define stdout		Soutput
+#define stderr		Serror
+
+#define	putc		Sputc
+#define	getc		Sgetc
+#define	fputc		Sputc
+#define	fgetc		Sgetc
+#define getw		Sgetw
+#define putw		Sputw
+#define fread		Sfread
+#define fwrite		Sfwrite
+#define	ungetc		Sungetc
+#define putchar		Sputchar
+#define getchar		Sgetchar
+#define feof		Sfeof
+#define ferror		Sferror
+#define clearerr	Sclearerr
+#define	fflush		Sflush
+#define	fseek		Sseek
+#define	ftell		Stell
+#define	fclose		Sclose
+#define fgets		Sfgets
+#define gets		Sgets
+#define	fputs		Sfputs
+#define	puts		Sputs
+#define	fprintf		Sfprintf
+#define	printf		Sprintf
+#define	vprintf		Svprintf
+#define	vfprintf	Svfprintf
+#define	sprintf		Ssprintf
+#define	vsprintf	Svsprintf
+#define fopen		Sopen_file
+#define fdopen		Sfdopen
+#define	fileno		Sfileno
+Svdprintf(const char *fm, va_list args);
+PL_EXPORT(int)		Sdprintf(const char *fm, ...);
+PL_EXPORT(int)		Slock(IOSTREAM *s);
+PL_EXPORT(int)		StryLock(IOSTREAM *s);
+PL_EXPORT(int)		Sunlock(IOSTREAM *s);
+PL_EXPORT(IOSTREAM *)	Snew(void *handle, int flags, IOFUNCTIONS *functions);
+PL_EXPORT(IOSTREAM *)	Sopen_file(const char *path, const char *how);
+PL_EXPORT(IOSTREAM *)	Sfdopen(int fd, const char *type);
+PL_EXPORT(int)	   	Sfileno(IOSTREAM *s);
+PL_EXPORT(IOSTREAM *)	Sopen_pipe(const char *command, const char *type);
+PL_EXPORT(IOSTREAM *)	Sopenmem(char **buffer, size_t *sizep, const char *mode);
+PL_EXPORT(IOSTREAM *)	Sopen_string(IOSTREAM *s, char *buf, size_t sz, const char *m);
+PL_EXPORT(int)		Sclosehook(void (*hook)(IOSTREAM *s));
+PL_EXPORT(void)		Sfree(void *ptr);
+PL_EXPORT(int)		Sset_filter(IOSTREAM *parent, IOSTREAM *filter);
+PL_EXPORT(void)		Ssetbuffer(IOSTREAM *s, char *buf, size_t size);
+
+PL_EXPORT(int64_t)	Stell64(IOSTREAM *s);
+PL_EXPORT(int)		Sseek64(IOSTREAM *s, int64_t pos, int whence);
+
+PL_EXPORT(int)		Ssetlocale(IOSTREAM *s, struct PL_locale *n, struct PL_locale **old);
+
+#ifdef __WINDOWS__
+#if defined(_WINSOCKAPI_) || defined(NEEDS_SWINSOCK)
+PL_EXPORT(SOCKET)	Swinsock(IOSTREAM *s);
+#endif
+#endif
+
+
+PL_EXPORT(int)		ScheckBOM(IOSTREAM *s);
+PL_EXPORT(int)		SwriteBOM(IOSTREAM *s);
+PL_EXPORT(ssize_t)	Sread_user(void *handle, char *buf, size_t size);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+#endif /*_PL_STREAM_H*/

library/dialect/swi/os/pl-buffer.c

@@ -0,0 +1,107 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+
+int
+growBuffer(Buffer b, size_t minfree)
+{ size_t osz = b->max - b->base, sz = osz;
+  size_t top = b->top - b->base;
+  char *new;
+
+  if ( b->max - b->top >= (int)minfree )
+    return TRUE;
+
+  if ( sz < 512 )
+    sz = 512;				/* minimum reasonable size */
+  while( top + minfree > sz )
+    sz *= 2;
+
+  if ( b->base == b->static_buffer )
+  { if ( !(new = malloc(sz)) )
+      return FALSE;
+
+    memcpy(new, b->static_buffer, osz);
+  } else
+  { if ( !(new = realloc(b->base, sz)) )
+      return FALSE;
+  }
+
+  b->base = new;
+  b->top = b->base + top;
+  b->max = b->base + sz;
+
+  return TRUE;
+}
+
+
+		 /*******************************
+		 *	    BUFFER RING		*
+		 *******************************/
+
+#define discardable_buffer	(LD->fli._discardable_buffer)
+#define buffer_ring		(LD->fli._buffer_ring)
+#define current_buffer_id	(LD->fli._current_buffer_id)
+
+Buffer
+findBuffer(int flags)
+{ GET_LD
+  Buffer b;
+
+  if ( flags & BUF_RING )
+  { if ( ++current_buffer_id == BUFFER_RING_SIZE )
+      current_buffer_id = 0;
+    b = &buffer_ring[current_buffer_id];
+  } else
+    b = &discardable_buffer;
+
+  if ( !b->base )
+    initBuffer(b);
+
+  emptyBuffer(b);
+  return b;
+}
+
+
+char *
+buffer_string(const char *s, int flags)
+{ Buffer b = findBuffer(flags);
+  size_t l = strlen(s) + 1;
+
+  addMultipleBuffer(b, s, l, char);
+
+  return baseBuffer(b, char);
+}
+
+
+int
+unfindBuffer(int flags)
+{ GET_LD
+  if ( flags & BUF_RING )
+  { if ( --current_buffer_id <= 0 )
+      current_buffer_id = BUFFER_RING_SIZE-1;
+  }
+
+  fail;
+}

library/dialect/swi/os/pl-buffer.h

@@ -0,0 +1,124 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef BUFFER_H_INCLUDED
+#define BUFFER_H_INCLUDED
+
+#define STATIC_BUFFER_SIZE (512)
+
+typedef struct
+{ char *	base;			/* allocated base */
+  char *	top;			/* pointer to top */
+  char *	max;			/* current location */
+  char		static_buffer[STATIC_BUFFER_SIZE];
+} tmp_buffer, *TmpBuffer;
+
+typedef struct
+{ char *	base;			/* allocated base */
+  char *	top;			/* pointer to top */
+  char *	max;			/* current location */
+  char		static_buffer[sizeof(char *)];
+} MAY_ALIAS buffer, *Buffer;
+
+int	growBuffer(Buffer b, size_t minfree);
+
+#define addBuffer(b, obj, type) \
+	do \
+	{ if ( (b)->top + sizeof(type) > (b)->max ) \
+	  { if ( !growBuffer((Buffer)b, sizeof(type)) ) \
+	      outOfCore(); \
+	  } \
+	  *((type *)(b)->top) = obj; \
+          (b)->top += sizeof(type); \
+	} while(0)
+
+#define addMultipleBuffer(b, ptr, times, type) \
+	do \
+	{ size_t _tms = (times); \
+          size_t _len = _tms * sizeof(type); \
+          type *_d, *_s = (type *)ptr; \
+	  if ( (b)->top + _len > (b)->max ) \
+	  { if ( !growBuffer((Buffer)b, _len) ) \
+	      outOfCore(); \
+	  } \
+          _d = (type *)(b)->top; \
+          while ( _tms-- ) \
+	    *_d++ = *_s++; \
+	  (b)->top = (char *)_d; \
+	} while(0)
+
+#define allocFromBuffer(b, bytes) \
+	f__allocFromBuffer((Buffer)(b), (bytes))
+
+static inline void*
+f__allocFromBuffer(Buffer b, size_t bytes)
+{ if ( b->top + bytes <= b->max ||
+       growBuffer(b, bytes) )
+  { void *top = b->top;
+
+    b->top += bytes;
+
+    return top;
+  }
+
+  return NULL;
+}
+
+
+#define baseBuffer(b, type)	 ((type *) (b)->base)
+#define topBuffer(b, type)       ((type *) (b)->top)
+#define inBuffer(b, addr)        ((char *) (addr) >= (b)->base && \
+				  (char *) (addr)  < (b)->top)
+#define fetchBuffer(b, i, type)	 (baseBuffer(b, type)[i])
+
+#define seekBuffer(b, cnt, type) ((b)->top = sizeof(type) * (cnt) + (b)->base)
+#define sizeOfBuffer(b)          ((b)->top - (b)->base)
+#define freeSpaceBuffer(b)	 ((b)->max - (b)->top)
+#define entriesBuffer(b, type)   (sizeOfBuffer(b) / sizeof(type))
+#define initBuffer(b)            ((b)->base = (b)->top = (b)->static_buffer, \
+				  (b)->max = (b)->base + \
+				  sizeof((b)->static_buffer))
+#define emptyBuffer(b)           ((b)->top  = (b)->base)
+#define isEmptyBuffer(b)         ((b)->top == (b)->base)
+#define popBuffer(b,type) \
+	((b)->top -= sizeof(type), *(type*)(b)->top)
+
+#define discardBuffer(b) \
+	do \
+	{ if ( (b)->base && (b)->base != (b)->static_buffer ) \
+	  { free((b)->base); \
+	    (b)->base = (b)->static_buffer; \
+	  } \
+	} while(0)
+
+
+		 /*******************************
+		 *	    FUNCTIONS		*
+		 *******************************/
+
+COMMON(Buffer)		findBuffer(int flags);
+COMMON(int)		unfindBuffer(int flags);
+COMMON(char *)		buffer_string(const char *s, int flags);
+
+#endif /*BUFFER_H_INCLUDED*/

library/dialect/swi/os/pl-codelist.c

@@ -0,0 +1,148 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+#if __YAP_PROLOG__
+#include "pl-codelist.h"
+#else
+#include "../pl-codelist.h"
+#endif
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide, CVT_code *status)
+
+If l represents a list of codes   or characters, return a buffer holding
+the characters. If wide == TRUE  the   buffer  contains  objects of type
+pl_wchar_t. Otherwise it contains traditional characters.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+Buffer
+codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide, CVT_result *result)
+{ GET_LD
+  Buffer b;
+  word list = valHandle(l);
+  word slow;
+  Word arg, tail;
+  int step_slow = TRUE;
+  enum { CHARS, CODES } type;
+
+  if ( isList(list) )
+  { intptr_t c = -1;
+
+    arg = argTermP(list, 0);
+    deRef(arg);
+
+    if ( isTaggedInt(*arg) )
+    { c = valInt(*arg);
+      type = CODES;
+    } else
+    { c = charCode(*arg);
+      type = CHARS;
+    }
+
+    result->culprit = *arg;
+    if ( c < 0 || (!wide && c > 0xff) )
+    { if ( canBind(*arg) )
+	result->status = CVT_partial;
+      else if ( c < 0 )
+	result->status = CVT_nocode;
+      else if ( c > 0xff )
+	result->status = CVT_wide;
+      return NULL;
+    }
+  } else if ( isNil(list) )
+  { return findBuffer(flags);
+  } else
+  { if ( canBind(list) )
+      result->status = CVT_partial;
+    else
+      result->status = CVT_nolist;
+
+    return NULL;
+  }
+
+  b = findBuffer(flags);
+
+  slow = list;
+  while( isList(list) )
+  { intptr_t c = -1;
+
+    arg = argTermP(list, 0);
+    deRef(arg);
+
+    switch(type)
+    { case CODES:
+	if ( isTaggedInt(*arg) )
+	  c = valInt(*arg);
+        break;
+      case CHARS:
+	c = charCode(*arg);
+        break;
+    }
+
+    if ( c < 0 || (!wide && c > 0xff) )
+    { result->culprit = *arg;
+
+      unfindBuffer(flags);		/* TBD: check unicode range */
+      if ( canBind(*arg) )
+	result->status = CVT_partial;
+      else if ( c < 0 )
+	result->status = (type == CODES ? CVT_nocode : CVT_nochar);
+      else if ( c > 0xff )
+	result->status = CVT_wide;
+      return NULL;
+    }
+
+    if ( wide )
+      addBuffer(b, (pl_wchar_t)c, pl_wchar_t);
+    else
+      addBuffer(b, (unsigned char)c, unsigned char);
+
+    tail = argTermP(list, 1);
+    deRef(tail);
+    list = *tail;
+    if ( list == slow )		/* cyclic */
+    { unfindBuffer(flags);
+      result->status = CVT_nolist;
+      return NULL;
+    }
+    if ( (step_slow = !step_slow) )
+    { tail = argTermP(slow, 1);
+      deRef(tail);
+      slow = *tail;
+    }
+  }
+  if ( !isNil(list) )
+  { unfindBuffer(flags);
+    if ( canBind(list) )
+      result->status = CVT_partial;
+    else
+      result->status = CVT_nolist;
+    return NULL;
+  }
+
+  result->status = CVT_ok;
+
+  return b;
+}

library/dialect/swi/os/pl-cstack.c

@@ -0,0 +1,741 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifdef _WIN64
+#define _WIN32_WINNT 0x0501            /* get RtlCaptureContext() */
+#endif
+
+#include "pl-incl.h"
+#include "os/pl-cstack.h"
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+The task of the library is to save   the  <N> most recent C stack traces
+for later retrieval. I.e., although this library   can  be used to print
+the stack in case of a crash, it is   intended  to _save_ the stack on a
+critical event such as GC and retrieve it  later if it turns out that an
+error occurs.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define SAVE_TRACES 10
+
+		 /*******************************
+		 *	      LIBUNWIND		*
+		 *******************************/
+
+#if !defined(BTRACE_DONE) && defined(HAVE_LIBUNWIND)
+#define BTRACE_DONE 1
+#define UNW_LOCAL_ONLY
+#include <libunwind.h>
+
+#define MAX_DEPTH 10
+
+typedef struct
+{ char name[32];				/* function called */
+  unw_word_t offset;				/* offset in function */
+} frame_info;
+
+typedef struct
+{ const char *name;				/* label of the backtrace */
+  int depth;					/* # frames collectec */
+  frame_info frame[MAX_DEPTH];			/* per-frame info */
+} btrace_stack;
+
+typedef struct btrace
+{ btrace_stack dumps[SAVE_TRACES];		/* ring of buffers */
+  int current;					/* next to fill */
+} btrace;
+
+
+void
+btrace_destroy(struct btrace *bt)
+{ free(bt);
+}
+
+
+static btrace *
+get_trace_store(void)
+{ GET_LD
+
+  if ( !LD->btrace_store )
+  { btrace *s = malloc(sizeof(*s));
+    if ( s )
+    { memset(s, 0, sizeof(*s));
+      LD->btrace_store = s;
+    }
+  }
+
+  return LD->btrace_store;
+}
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+next_btrace_id() produces the  id  for  the   next  backtrace  and  sets
+bt->current to the subsequent id. Although bt is thread-local, it may be
+called from a signal  handler  or   (Windows)  exception.  We cannot use
+locking because the mutex functions are not   async  signal safe. So, we
+use atomic instructions if possible. Otherwise, we ensure consistency of
+the datastructures, but we may overwrite an older stack trace.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+static int
+next_btrace_id(btrace *bt)
+{ int current;
+#ifdef COMPARE_AND_SWAP
+  int next;
+
+  do
+  { current = bt->current;
+    next = current+1;
+    if ( next == SAVE_TRACES )
+      next = 0;
+  } while ( !COMPARE_AND_SWAP(&bt->current, current, next) );
+#else
+  current = bt->current++ % SAVE_TRACES;
+
+  if ( bt->current >= SAVE_TRACES )
+    bt->current %= SAVE_TRACES;
+#endif
+
+  return current;
+}
+
+
+void
+save_backtrace(const char *why)
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { btrace_stack *s;
+    unw_cursor_t cursor; unw_context_t uc;
+    int depth;
+    int current = next_btrace_id(bt);
+
+    s = &bt->dumps[current];
+    unw_getcontext(&uc);
+    unw_init_local(&cursor, &uc);
+    for(depth=0; unw_step(&cursor) > 0 && depth < MAX_DEPTH; depth++)
+    { unw_get_proc_name(&cursor,
+			s->frame[depth].name, sizeof(s->frame[depth].name),
+			&s->frame[depth].offset);
+    }
+    s->name = why;
+    s->depth = depth;
+  }
+
+}
+
+
+static void
+print_trace(btrace *bt, int me)
+{ btrace_stack *s = &bt->dumps[me];
+
+  if ( s && s->name )
+  { int depth;
+
+    Sdprintf("Stack trace labeled \"%s\":\n", s->name);
+    for(depth=0; depth<s->depth; depth++)
+    { Sdprintf("  [%d] %s+%p\n", depth,
+	       s->frame[depth].name,
+	       (void*)s->frame[depth].offset);
+    }
+  } else
+  { Sdprintf("No stack trace\n");
+  }
+}
+
+
+void
+print_backtrace(int last)		/* 1..SAVE_TRACES */
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { int me = bt->current-last;
+    if ( me < 0 )
+      me += SAVE_TRACES;
+
+    print_trace(bt, me);
+  } else
+  { Sdprintf("No backtrace store?\n");
+  }
+}
+
+
+void
+print_backtrace_named(const char *why)
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { int me = bt->current-1;
+
+    for(;;)
+    { if ( --me < 0 )
+	me += SAVE_TRACES;
+      if ( bt->dumps[me].name && strcmp(bt->dumps[me].name, why) == 0 )
+      { print_trace(bt, me);
+	return;
+      }
+      if ( me == bt->current-1 )
+	break;
+    }
+  }
+
+  Sdprintf("No backtrace named %s\n", why);
+}
+
+#endif /*HAVE_LIBUNWIND*/
+
+
+		 /*******************************
+		 *	       GLIBC		*
+		 *******************************/
+
+#if !defined(BTRACE_DONE) && defined(HAVE_EXECINFO_H) && !defined(DMALLOC)
+#define BTRACE_DONE 1
+#include <execinfo.h>
+#include <string.h>
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This implementation uses the libgcc unwinding capabilities.
+
+Disabled of dmalloc is used because the  free of the memory allocated by
+backtrace_symbols() is considered an error by dmalloc.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+typedef struct btrace
+{ char	      **symbols[SAVE_TRACES];
+  const char   *why[SAVE_TRACES];
+  size_t	sizes[SAVE_TRACES];
+  int		current;
+} btrace;
+
+
+void
+btrace_destroy(struct btrace *bt)
+{ int i;
+
+  for(i=0; i<SAVE_TRACES; i++)
+  { if ( bt->symbols[i] )
+      free(bt->symbols[i]);
+  }
+
+  free(bt);
+}
+
+
+static btrace *
+get_trace_store(void)
+{ GET_LD
+
+  if ( !LD->btrace_store )
+  { btrace *s = malloc(sizeof(*s));
+    if ( s )
+    { memset(s, 0, sizeof(*s));
+      LD->btrace_store = s;
+    }
+  }
+
+  return LD->btrace_store;
+}
+
+
+/* Copy of same function above.  Relies on a different btrace structure.
+   Ideally, this should be shared :-(
+*/
+
+static int
+next_btrace_id(btrace *bt)
+{ int current;
+#ifdef COMPARE_AND_SWAP
+  int next;
+
+  do
+  { current = bt->current;
+    next = current+1;
+    if ( next == SAVE_TRACES )
+      next = 0;
+  } while ( !COMPARE_AND_SWAP(&bt->current, current, next) );
+#else
+  current = bt->current++ % SAVE_TRACES;
+
+  if ( bt->current >= SAVE_TRACES )
+    bt->current %= SAVE_TRACES;
+#endif
+
+  return current;
+}
+
+
+void
+save_backtrace(const char *why)
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { void *array[100];
+    size_t frames;
+    int current = next_btrace_id(bt);
+
+    frames = backtrace(array, sizeof(array)/sizeof(void *));
+    bt->sizes[current] = frames;
+    if ( bt->symbols[current] )
+      free(bt->symbols[current]);
+    bt->symbols[current] = backtrace_symbols(array, frames);
+    bt->why[current] = why;
+  }
+}
+
+
+static void
+print_trace(btrace *bt, int me)
+{ size_t i;
+
+  if ( bt->why[me] )
+  { Sdprintf("Stack trace labeled \"%s\":\n", bt->why[me]);
+
+    for(i=0; i<bt->sizes[me]; i++)
+      Sdprintf("  [%d] %s\n", i, bt->symbols[me][i]);
+  } else
+  { Sdprintf("No stack trace\n");
+  }
+}
+
+void
+print_backtrace(int last)		/* 1..SAVE_TRACES */
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { int me = bt->current-last;
+    if ( me < 0 )
+      me += SAVE_TRACES;
+
+    print_trace(bt, me);
+  } else
+  { Sdprintf("No backtrace store?\n");
+  }
+}
+
+
+void
+print_backtrace_named(const char *why)
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { int me = bt->current-1;
+
+    for(;;)
+    { if ( --me < 0 )
+	me += SAVE_TRACES;
+      if ( bt->why[me] && strcmp(bt->why[me], why) == 0 )
+      { print_trace(bt, me);
+	return;
+      }
+      if ( me == bt->current-1 )
+	break;
+    }
+  }
+
+  Sdprintf("No backtrace named %s\n", why);
+}
+
+
+#endif /*HAVE_EXECINFO_H*/
+
+
+		 /*******************************
+		 *	  ADD AS HANDLER	*
+		 *******************************/
+
+#ifdef BTRACE_DONE
+
+static void
+crashHandler(int sig)
+{ Sdprintf("\nSWI-Prolog [thread %d]: received fatal signal %d (%s)\n",
+	   PL_thread_self(), sig, signal_name(sig));
+  save_backtrace("crash");
+  print_backtrace_named("crash");
+  abort();
+}
+
+void
+initBackTrace(void)
+{
+#ifdef SIGSEGV
+  PL_signal(SIGSEGV, crashHandler);
+#endif
+#ifdef SIGILL
+  PL_signal(SIGILL, crashHandler);
+#endif
+#ifdef SIGBUS
+  PL_signal(SIGBUS, crashHandler);
+#endif
+#ifdef SIGFPE
+  PL_signal(SIGFPE, crashHandler);
+#endif
+}
+
+#endif
+
+
+		 /*******************************
+		 *   WINDOWS IMPLEMENTATION	    *
+		 *******************************/
+
+
+#if !defined(BTRACE_DONE) && defined(__WINDOWS__) && defined(HAVE_DBGHELP_H)
+#include <windows.h>
+#include <dbghelp.h>
+#define MAX_SYMBOL_LEN 1024
+#define MAX_DEPTH 10
+#define BTRACE_DONE 1
+
+#define MAX_FUNCTION_NAME_LENGTH 32
+/* Note that the module name may include the full path in some versions
+   of dbghelp. For me, 32 was not enough to see the module name in some
+   cases.
+*/
+#define MAX_MODULE_NAME_LENGTH 64
+
+#define LOCK()   PL_LOCK(L_CSTACK)
+#define UNLOCK() PL_UNLOCK(L_CSTACK)
+
+typedef struct
+{ char name[MAX_FUNCTION_NAME_LENGTH];	/* function called */
+  DWORD64 offset;			/* offset in function */
+  char module[MAX_MODULE_NAME_LENGTH];	/* module of function */
+  DWORD module_reason;                  /* reason for module being absent */
+} frame_info;
+
+typedef struct
+{ const char *name;			/* label of the backtrace */
+  int depth;				/* # frames collectec */
+  frame_info frame[MAX_DEPTH];		/* per-frame info */
+} btrace_stack;
+
+typedef struct btrace
+{ btrace_stack dumps[SAVE_TRACES];	/* ring of buffers */
+  int current;				/* next to fill */
+} btrace;
+
+void
+btrace_destroy(struct btrace *bt)
+{ free(bt);
+}
+
+
+static btrace *
+get_trace_store(void)
+{ GET_LD
+
+  if ( !LD->btrace_store )
+  { btrace *s = malloc(sizeof(*s));
+    if ( s )
+    { memset(s, 0, sizeof(*s));
+      LD->btrace_store = s;
+    }
+  }
+
+  return LD->btrace_store;
+}
+
+/* Copy of same function above.  Relies on a different btrace structure.
+   Ideally, this should be shared :-(
+*/
+
+static int
+next_btrace_id(btrace *bt)
+{ int current;
+#ifdef COMPARE_AND_SWAP
+  int next;
+
+  do
+  { current = bt->current;
+    next = current+1;
+    if ( next == SAVE_TRACES )
+      next = 0;
+  } while ( !COMPARE_AND_SWAP(&bt->current, current, next) );
+#else
+  current = bt->current++ % SAVE_TRACES;
+
+  if ( bt->current >= SAVE_TRACES )
+    bt->current %= SAVE_TRACES;
+#endif
+
+  return current;
+}
+
+int backtrace(btrace_stack* trace, PEXCEPTION_POINTERS pExceptionInfo)
+{ STACKFRAME64 frame;
+  CONTEXT context;
+  int rc = 0;
+  HANDLE hThread = GetCurrentThread();
+  HANDLE hProcess = GetCurrentProcess();
+  char symbolScratch[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LEN];
+  SYMBOL_INFO* symbol = (SYMBOL_INFO*)&symbolScratch;
+  IMAGEHLP_MODULE64 moduleInfo;
+  DWORD64 offset;
+  DWORD imageType;
+  int skip = 0;
+  int depth = 0;
+
+  if (pExceptionInfo == NULL)
+  { memset(&context, 0, sizeof(CONTEXT));
+    // If we dont have the context, then we can get the current one from the CPU
+    // However, we should skip the first N frames, since these relate to the
+    // exception handler itself
+    // Obviously N is a magic number - it might differ if this code is modified!
+#if _WIN32_WINNT > 0x0500
+    // Good, just use RtlCaptureContext
+    skip = 2;
+    RtlCaptureContext(&context);
+#else
+    // For earlier than WinXPsp1 we have to do some weird stuff
+    // For win32, we can use inline assembly to get eip, esp and ebp but
+    // the MSVC2005 compiler refuses to emit inline assembly for AMD64
+    // Luckily, the oldest AMD64 build of Windows is XP, so we should be able to
+    // use RtlCaptureContext!
+#ifdef WIN64
+#error You appear to have a 64 bit build of a pre-XP version of Windows?!
+#else
+    skip = 2;
+    __asm
+    { call steal_eip
+      steal_eip:
+      pop eax
+      mov context.Eip, eax
+      mov eax, ebp
+      mov context.Ebp, eax
+      mov eax, esp
+      mov context.Esp, eax
+    }
+#endif
+
+#endif
+  } else
+  { context = *(pExceptionInfo->ContextRecord);
+  }
+
+  ZeroMemory(&frame, sizeof( STACKFRAME64));
+  memset(&moduleInfo,0,sizeof(IMAGEHLP_MODULE64));
+  moduleInfo.SizeOfStruct = sizeof(IMAGEHLP_MODULE64);
+  rc = SymInitialize(hProcess, NULL, TRUE);
+  if (rc == 0)
+    return 0;
+
+#ifdef _WIN64
+   imageType = IMAGE_FILE_MACHINE_AMD64;
+   frame.AddrPC.Offset = context.Rip;
+   frame.AddrFrame.Offset = context.Rsp;
+   frame.AddrStack.Offset = context.Rsp;
+#else
+   imageType = IMAGE_FILE_MACHINE_I386;
+   frame.AddrPC.Offset = context.Eip;
+   frame.AddrFrame.Offset = context.Ebp;
+   frame.AddrStack.Offset = context.Esp;
+#endif
+   frame.AddrPC.Mode = AddrModeFlat;
+   frame.AddrFrame.Mode = AddrModeFlat;
+   frame.AddrStack.Mode = AddrModeFlat;
+
+   while(depth < MAX_DEPTH &&
+	 (rc =  StackWalk64(imageType,
+			    hProcess,
+			    hThread,
+			    &frame,
+			    &context,
+			    NULL,
+			    SymFunctionTableAccess64,
+			    SymGetModuleBase64,
+			    NULL)) != 0)
+   { int hasModule = 0;
+     BOOL hasSymbol = FALSE;
+
+     if (skip > 0)
+     { skip--;
+       continue;
+     }
+
+     memset(symbol, 0, sizeof(SYMBOL_INFO) + MAX_SYMBOL_LEN);
+     symbol->SizeOfStruct = sizeof(SYMBOL_INFO);
+     symbol->MaxNameLen = MAX_SYMBOL_LEN;
+     trace->frame[depth].offset = frame.AddrPC.Offset;
+     hasModule = SymGetModuleInfo64(hProcess, frame.AddrPC.Offset, &moduleInfo);
+
+     if (hasModule == 0)
+     {
+       // Note that this CAN be caused by a very out of date dbghelp.dll,
+       // like the one that ships with Windows XP
+       // Dropping version 6.x into the bin directory can magically
+       // make this work. At least we will have the offset
+       trace->frame[depth].name[0] = '\0';
+       trace->frame[depth].module[0] = '\0';
+       trace->frame[depth].module_reason = GetLastError();
+     } else
+     { hasSymbol = SymFromAddr(hProcess, frame.AddrPC.Offset, &offset, symbol);
+       strncpy(trace->frame[depth].module,
+	       moduleInfo.ImageName,
+	       MAX_MODULE_NAME_LENGTH);
+       trace->frame[depth].module[MAX_MODULE_NAME_LENGTH-1] = '\0';
+       trace->frame[depth].module_reason = 0;
+       if (hasSymbol)
+       { strncpy(trace->frame[depth].name,
+		 symbol->Name,
+		 MAX_FUNCTION_NAME_LENGTH);
+         trace->frame[depth].name[MAX_FUNCTION_NAME_LENGTH-1] = '\0';
+       } else
+       { trace->frame[depth].name[0] = '\0';
+       }
+     }
+     depth++;
+   }
+   return depth;
+}
+
+void
+win_save_backtrace(const char *why, PEXCEPTION_POINTERS pExceptionInfo)
+{ btrace *bt = get_trace_store();
+  if ( bt )
+  { int current = next_btrace_id(bt);
+    btrace_stack *s = &bt->dumps[current];
+    LOCK();
+    s->depth = backtrace(s, pExceptionInfo);
+    UNLOCK();
+    s->name = why;
+  }
+}
+
+
+void save_backtrace(const char *why)
+{ win_save_backtrace(why, NULL);
+}
+
+
+static void
+print_trace(btrace *bt, int me)
+{ btrace_stack *s = &bt->dumps[me];
+  if ( s->name )
+  { int depth;
+
+    Sdprintf("Stack trace labeled \"%s\":\n", s->name);
+    for(depth=0; depth<s->depth; depth++)
+    { Sdprintf("  [%d] <%s>:%s+%p\n", depth,
+               (s->frame[depth].module[0] == 0) ? "unknown module"
+						: s->frame[depth].module,
+	       s->frame[depth].name,
+	       (void*)s->frame[depth].offset);
+    }
+  } else
+  { Sdprintf("No stack trace\n");
+  }
+}
+
+
+
+void
+print_backtrace(int last)		/* 1..SAVE_TRACES */
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { int me = bt->current-last;
+    if ( me < 0 )
+      me += SAVE_TRACES;
+
+    print_trace(bt, me);
+  } else
+  { Sdprintf("No backtrace store?\n");
+  }
+}
+
+
+void
+print_backtrace_named(const char *why)
+{ btrace *bt = get_trace_store();
+
+  if ( bt )
+  { int me = bt->current-1;
+
+    for(;;)
+    { if ( --me < 0 )
+	me += SAVE_TRACES;
+      if ( bt->dumps[me].name && strcmp(bt->dumps[me].name, why) == 0 )
+      { print_trace(bt, me);
+	return;
+      }
+      if ( me == bt->current-1 )
+	break;
+    }
+  }
+
+  Sdprintf("No backtrace named %s\n", why);
+}
+
+static LONG WINAPI crashHandler(PEXCEPTION_POINTERS pExceptionInfo)
+{ win_save_backtrace("crash", pExceptionInfo);
+  print_backtrace_named("crash");
+  abort();
+
+  return EXCEPTION_CONTINUE_SEARCH; /* ? */
+}
+
+void
+initBackTrace(void)
+{ SetUnhandledExceptionFilter(crashHandler);
+}
+
+#endif /*__WINDOWS__*/
+
+
+	         /*******************************
+		 *   FALLBACK IMPLEMENTATION	*
+		 *******************************/
+
+
+#ifndef BTRACE_DONE
+
+void
+save_backtrace(const char *why)
+{
+}
+
+void
+btrace_destroy(struct btrace *bt)
+{
+}
+
+void
+print_backtrace(int last)
+{ Sdprintf("%s:%d C-stack dumps are not supported on this platform\n",
+	   __FILE__, __LINE__);
+}
+
+void
+print_backtrace_named(const char *why)
+{ Sdprintf("%s:%d C-stack dumps are not supported on this platform\n",
+	   __FILE__, __LINE__);
+}
+
+void
+initBackTrace(void)
+{
+}
+
+#endif /*BTRACE_DONE*/

library/dialect/swi/os/pl-cstack.h

@@ -0,0 +1,34 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_CSTACK_H_INCLUDED
+#define PL_CSTACK_H_INCLUDED
+
+COMMON(void)	save_backtrace(const char *why);
+COMMON(void)	btrace_destroy(struct btrace *bt);
+COMMON(void)	print_backtrace(int last);		/* 1..SAVE_TRACES */
+COMMON(void)	print_backtrace_named(const char *why);
+COMMON(void)	initBackTrace(void);
+
+#endif /*PL_CSTACK_H_INCLUDED*/

library/dialect/swi/os/pl-ctype.h

@@ -0,0 +1,83 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2013, University of Amsterdam
+			      VU University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+extern const char _PL_char_types[];	/* array of character types */
+
+#define CT  0			/* control-character */
+#define SP  1			/* space */
+#define SO  2			/* solo character */
+#define SY  3			/* symbol character */
+#define PU  4			/* Punctuation character */
+#define DQ  5			/* Double quote */
+#define SQ  6			/* Single quote */
+#define BQ  7			/* Back quote */
+#define UC  8			/* Uppercase character */
+#define LC  9			/* Lowercase character */
+#define DI 10			/* Digit */
+
+#define isControl(c)	(_PL_char_types[(unsigned)(c) & 0xff] == CT)
+#define isBlank(c)	(_PL_char_types[(unsigned)(c) & 0xff] == SP)
+#define isGraph(c)	(_PL_char_types[(unsigned)(c) & 0xff]  > SP)
+#define isDigit(c)	(_PL_char_types[(unsigned)(c) & 0xff] == DI)
+#define isLower(c)	(_PL_char_types[(unsigned)(c) & 0xff] == LC)
+#define isUpper(c)	(_PL_char_types[(unsigned)(c) & 0xff] == UC)
+#define isSymbol(c)	(_PL_char_types[(unsigned)(c) & 0xff] == SY)
+#define isPunct(c)	(_PL_char_types[(unsigned)(c) & 0xff] == PU)
+#define isSolo(c)	(_PL_char_types[(unsigned)(c) & 0xff] == SO)
+#define isAlpha(c)	(_PL_char_types[(unsigned)(c) & 0xff] >= UC)
+#define isLetter(c)	(isLower(c) || isUpper(c))
+#define isSign(c)	((c) == '-' || (c) == '+')
+
+#define toLower(c)	((c) + 'a' - 'A')
+#define makeLower(c)	((c) >= 'A' && (c) <= 'Z' ? toLower(c) : (c))
+
+#define matchingBracket(c)	((c) == '[' ? ']' :\
+				 (c) == '{' ? '}' :\
+				 (c) == '(' ? ')' : EOS)
+#define Control(c)		((c) == '?' ? 127 : (c) - '@')
+
+
+		 /*******************************
+		 *    WIDE CHARACTER SUPPORT	*
+		 *******************************/
+
+#include <wctype.h>
+#include <wchar.h>
+
+#define PlCharType(c, t, w) \
+	((unsigned)(c) <= 0xff ? (_PL_char_types[(unsigned char)(c)] t) : w)
+
+#define isControlW(c)	PlCharType(c, == CT, iswcntrl((wint_t)c))
+#define isBlankW(c)	PlCharType(c, == SP, iswspace((wint_t)c))
+#define isDigitW(c)	PlCharType(c, == DI, FALSE)
+#define isLowerW(c)	PlCharType(c, == LC, iswlower((wint_t)c))
+#define isUpperW(c)	PlCharType(c, == UC, iswupper((wint_t)c))
+#define isSymbolW(c)	PlCharType(c, == SY, FALSE)
+#define isPunctW(c)	PlCharType(c, == PU, FALSE)
+#define isSoloW(c)	PlCharType(c, == SO, FALSE)
+#define isAlphaW(c)	PlCharType(c, >= UC, iswalnum((wint_t)c))
+#define isLetterW(c)	(PlCharType(c, == LC, iswalpha((wint_t)c)) || \
+			 PlCharType(c, == UC, FALSE))
+
+#define toLowerW(c)	((unsigned)(c) <= 'Z' ? (c) + 'a' - 'A' : towlower(c))
+#define makeLowerW(c)	((c) >= 'A' && (c) <= 'Z' ? toLower(c) : towlower(c))

library/dialect/swi/os/pl-dtoa.c

@@ -0,0 +1,71 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2010, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+#include "pl-dtoa.h"
+
+#ifdef WORDS_BIGENDIAN
+#define IEEE_MC68k 1
+#else
+#define IEEE_8087 1
+#endif
+
+#define MALLOC PL_malloc
+#define FREE PL_free
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Long must be a 32-bit int.  For now we use int.  Ideally we would use
+int32_t, but MS does not yet support stdint.h.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define Long int			/* 32-bits */
+
+#ifdef _REENTRANT
+#define MULTIPLE_THREADS
+
+/* TBD: Use the pl-thread.[ch] locks for better speed on Windows
+*/
+
+static pthread_mutex_t mutex_0 = PTHREAD_MUTEX_INITIALIZER;
+static pthread_mutex_t mutex_1 = PTHREAD_MUTEX_INITIALIZER;
+
+static inline void
+ACQUIRE_DTOA_LOCK(int n)
+{ if ( n == 0 )
+    pthread_mutex_lock(&mutex_0);
+  else
+    pthread_mutex_lock(&mutex_1);
+}
+
+static inline void
+FREE_DTOA_LOCK(int n)
+{ if ( n == 0 )
+    pthread_mutex_unlock(&mutex_0);
+  else
+    pthread_mutex_unlock(&mutex_1);
+}
+
+#endif /*MULTIPLE_THREADS*/
+
+#include "dtoa.c"

library/dialect/swi/os/pl-dtoa.h

@@ -0,0 +1,42 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2010, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_DTOA_H_INCLUDED
+#define PL_DTOA_H_INCLUDED
+
+#ifdef dtoa
+#undef dtoa
+#endif
+#define dtoa   PL_dtoa			/* avoid library conflicts */
+#ifdef strtod				/* avoid redefinition warnings */
+#undef strtod
+#endif
+#define strtod PL_strtod		/* avoid library conflicts */
+
+COMMON(char *)	dtoa(double dd, int mode, int ndigits,
+		     int *decpt, int *sign, char **rve);
+COMMON(void)	freedtoa(char *s);
+double		strtod(const char *in, char **end);
+
+#endif /*PL_DTOA_H_INCLUDED*/

library/dialect/swi/os/pl-error.c

@@ -0,0 +1,617 @@
+
+#include	<stdlib.h>
+#include	<stdio.h>
+#include "pl-incl.h"
+#if HAVE_ERRNO_H
+#include	<errno.h>
+#endif
+
+void			fatalError(const char *fm, ...) {exit(1);}
+int			printMessage(atom_t severity, ...);
+
+		 /*******************************
+		 *    ERROR-CHECKING *_get()	*
+		 *******************************/
+
+int
+PL_get_nchars_ex(term_t t, size_t *len, char **s, unsigned int flags)
+{ return PL_get_nchars(t, len, s, flags|CVT_EXCEPTION);
+}
+
+
+int
+PL_get_chars_ex(term_t t, char **s, unsigned int flags)
+{ return PL_get_nchars(t, NULL, s, flags|CVT_EXCEPTION);
+}
+
+
+#undef PL_get_atom_ex
+
+int
+PL_get_atom_ex__LD(term_t t, atom_t *a ARG_LD)
+{ if ( PL_get_atom(t, a) )
+    succeed;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, t);
+}
+
+int
+PL_get_atom_ex(term_t t, atom_t *a)
+{ GET_LD
+  if ( PL_get_atom(t, a) )
+    succeed;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, t);
+}
+
+
+int
+PL_get_integer_ex(term_t t, int *i)
+{ if ( PL_get_integer(t, i) )
+    succeed;
+
+  if ( PL_is_integer(t) )
+    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_int);
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
+}
+
+
+int
+PL_get_long_ex(term_t t, long *i)
+{ if ( PL_get_long(t, i) )
+    succeed;
+
+  if ( PL_is_integer(t) )
+    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_long);
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
+}
+
+
+int
+PL_get_int64_ex(term_t t, int64_t *i)
+{ if ( PL_get_int64(t, i) )
+    succeed;
+
+  if ( PL_is_integer(t) )
+    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_int64_t);
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
+}
+
+
+int
+PL_get_intptr_ex(term_t t, intptr_t *i)
+{
+#if SIZEOF_LONG != SIZEOF_VOIDP && SIZEOF_VOIDP == 8
+   return PL_get_int64_ex(t, (int64_t *)i);
+#else
+   return PL_get_long_ex(t, (long*)i);
+#endif
+}
+
+int
+PL_get_pointer_ex(term_t t, void **i)
+{
+#if SIZEOF_LONG != SIZEOF_VOIDP && SIZEOF_VOIDP == 8
+  return PL_get_int64_ex(t, (int64_t *)i);
+#else
+   return PL_get_long_ex(t, (long *)i);
+#endif
+}
+
+
+int
+PL_get_size_ex(term_t t, size_t *i)
+{ int64_t val;
+
+  if ( !PL_get_int64_ex(t, &val) )
+    fail;
+  if ( val < 0 )
+    return PL_error(NULL, 0, NULL, ERR_DOMAIN,
+                    ATOM_not_less_than_zero, t);
+#if SIZEOF_VOIDP < 8
+#if SIZEOF_LONG == SIZEOF_VOIDP
+  if ( val > (int64_t)ULONG_MAX )
+    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_size_t);
+#endif
+#endif
+
+  *i = (size_t)val;
+
+  return TRUE;
+}
+
+
+int
+PL_get_bool_ex(term_t t, int *ip)
+{ if ( PL_get_bool(t, ip) )
+    succeed;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, t);
+}
+
+
+int
+PL_get_float_ex(term_t t, double *f)
+{ if ( PL_get_float(t, f) )
+    succeed;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_float, t);
+}
+
+
+int
+PL_get_char_ex(term_t t, int *p, int eof)
+{ if ( PL_get_char(t, p, eof) )
+    succeed;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, t);
+}
+
+
+int
+PL_unify_list_ex(term_t l, term_t h, term_t t)
+{ if ( PL_unify_list(l, h, t) )
+    succeed;
+
+  if ( PL_get_nil(l) )
+    fail;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
+}
+
+
+int
+PL_unify_nil_ex(term_t l)
+{ if ( PL_unify_nil(l) )
+    succeed;
+
+  if ( PL_is_list(l) )
+    fail;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
+}
+
+
+int
+PL_get_list_ex(term_t l, term_t h, term_t t)
+{ if ( PL_get_list(l, h, t) )
+    succeed;
+
+  if ( PL_get_nil(l) )
+    fail;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
+}
+
+int
+PL_get_nil_ex(term_t l)
+{ if ( PL_get_nil(l) )
+    succeed;
+
+  if ( PL_is_list(l) )
+    fail;
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
+}
+
+
+int
+PL_get_module_ex(term_t name, module_t *m)
+{ if ( !PL_get_module(name, m) )
+    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, name);
+
+  succeed;
+}
+
+int
+PL_unify_bool_ex(term_t t, int val)
+{ GET_LD
+  int v;
+
+  if ( PL_is_variable(t) )
+    return PL_unify_atom(t, val ? ATOM_true : ATOM_false);
+  if ( PL_get_bool(t, &v) )
+  { if ( (!val && !v) || (val && v) )
+      succeed;
+    fail;
+  }
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, t);
+}
+
+		 /*******************************
+		 *	  TYPICAL ERRORS	*
+		 *******************************/
+
+int
+PL_instantiation_error(term_t actual)
+{ return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
+}
+
+int
+PL_uninstantiation_error(term_t actual)
+{ return PL_error(NULL, 0, NULL, ERR_UNINSTANTIATION, 0, actual);
+}
+
+int
+PL_representation_error(const char *resource)
+{ atom_t r = PL_new_atom(resource);
+  int rc = PL_error(NULL, 0, NULL, ERR_RESOURCE, r);
+  PL_unregister_atom(r);
+
+  return rc;
+}
+
+
+int
+PL_type_error(const char *expected, term_t actual)
+{ return PL_error(NULL, 0, NULL, ERR_CHARS_TYPE, expected, actual);
+}
+
+
+int
+PL_domain_error(const char *expected, term_t actual)
+{ atom_t a = PL_new_atom(expected);
+  int rc = PL_error(NULL, 0, NULL, ERR_DOMAIN, a, actual);
+  PL_unregister_atom(a);
+
+  return rc;
+}
+
+
+int
+PL_existence_error(const char *type, term_t actual)
+{ atom_t a = PL_new_atom(type);
+  int rc = PL_error(NULL, 0, NULL, ERR_EXISTENCE, a, actual);
+  PL_unregister_atom(a);
+
+  return rc;
+}
+
+
+int
+PL_permission_error(const char *op, const char *type, term_t obj)
+{ atom_t t = PL_new_atom(type);
+  atom_t o = PL_new_atom(op);
+  int rc = PL_error(NULL, 0, NULL, ERR_PERMISSION, o, t, obj);
+
+  PL_unregister_atom(t);
+  PL_unregister_atom(o);
+
+  return rc;
+}
+
+
+int
+PL_resource_error(const char *resource)
+{ atom_t r = PL_new_atom(resource);
+  int rc = PL_error(NULL, 0, NULL, ERR_RESOURCE, r);
+
+  PL_unregister_atom(r);
+
+  return rc;
+}
+
+int
+PL_no_memory(void)
+{ return PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_memory);
+}
+
+
+
+word
+notImplemented(char *name, int arity)
+{ return (word)PL_error(NULL, 0, NULL, ERR_NOT_IMPLEMENTED_PROC, name, arity);
+}
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+printMessage(atom_t severity, ...)
+
+Calls print_message(severity, term), where  ...   are  arguments  as for
+PL_unify_term(). This predicate saves possible   pending  exceptions and
+restores them to make the call from B_THROW possible.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define OK_RECURSIVE 10
+
+int
+printMessage(atom_t severity, ...)
+{ GET_LD
+    //wakeup_state wstate;
+  term_t av;
+  predicate_t pred = RepPredProp(PredPropByFunc(FunctorPrintMessage,PROLOG_MODULE)); //PROCEDURE_print_message2;
+  va_list args;
+  int rc;
+
+  if ( ++LD->in_print_message >= OK_RECURSIVE*3 )
+    fatalError("printMessage(): recursive call\n");
+  /*  if ( !saveWakeup(&wstate, TRUE PASS_LD) )
+  { LD->in_print_message--;
+    return FALSE;
+  }
+  */
+
+  av = PL_new_term_refs(2);
+  va_start(args, severity);
+  PL_put_atom(av+0, severity);
+  rc = PL_unify_termv(av+1, args);
+  va_end(args);
+
+  if ( rc )
+    { if ( isDefinedProcedure(pred)  && LD->in_print_message <= OK_RECURSIVE )
+    { rc = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_CATCH_EXCEPTION,
+			     pred, av);
+    } else if ( LD->in_print_message <= OK_RECURSIVE*2 )
+    { Sfprintf(Serror, "Message: ");
+      rc = PL_write_term(Serror, av+1, 1200, 0);
+      Sfprintf(Serror, "\n");
+    } else				/* in_print_message == 2 */
+    { Sfprintf(Serror, "printMessage(): recursive call\n");
+    }
+  }
+
+  /* restoreWakeup(&wstate PASS_LD); */
+  LD->in_print_message--;
+
+  return rc;
+}
+
+
+int PL_error(const char *pred, int arity, const char *msg, PL_error_code id, ...)
+{
+  GET_LD
+  char msgbuf[50];
+  term_t formal, swi, predterm, msgterm, except;
+  va_list args;
+  int rc = TRUE;
+
+  formal    = PL_new_term_ref();
+  swi    = PL_new_term_ref();
+  predterm    = PL_new_term_ref();
+  msgterm    = PL_new_term_ref();
+  except    = PL_new_term_ref();
+
+  if ( msg == ((char *)(-1)) )
+    { if ( errno == EPLEXCEPTION )
+	return FALSE;
+      msg = OsError();
+    }
+
+  /* This would really require having pl-error.c, but we'll make do so as */
+  va_start(args, id);
+  switch(id) {
+  case ERR_INSTANTIATION:
+  err_instantiation:
+    PL_unify_atom(formal, ATOM_instantiation_error);
+    break;
+  case ERR_UNINSTANTIATION:
+    { int argn = va_arg(args, int);
+      term_t bound = va_arg(args, term_t);
+
+      if ( !msg && argn > 0 )
+      { Ssprintf(msgbuf, "%d-%s argument",
+		 argn, argn == 1 ? "st" : argn == 2 ? "nd" : "th");
+	msg = msgbuf;
+      }
+
+      rc = PL_unify_term(formal,
+			 PL_FUNCTOR, FUNCTOR_uninstantiation_error1,
+			   PL_TERM, bound);
+      break;
+    }
+  case ERR_TYPE:			/* ERR_INSTANTIATION if var(actual) */
+    { atom_t expected = va_arg(args, atom_t);
+      term_t actual   = va_arg(args, term_t);
+
+      if ( PL_is_variable(actual) && expected != ATOM_variable )
+	goto err_instantiation;
+
+      PL_unify_term(formal,
+		    PL_FUNCTOR, FUNCTOR_type_error2,
+		      PL_ATOM, expected,
+		      PL_TERM, actual);
+      break;
+    }
+  case ERR_DOMAIN:			/*  ERR_INSTANTIATION if var(arg) */
+    { atom_t domain = va_arg(args, atom_t);
+      term_t arg    = va_arg(args, term_t);
+
+      if ( PL_is_variable(arg) )
+	goto err_instantiation;
+
+      PL_unify_term(formal,
+		    PL_FUNCTOR, FUNCTOR_domain_error2,
+		      PL_ATOM, domain,
+		      PL_TERM, arg);
+      break;
+    }
+  case ERR_REPRESENTATION:
+    { atom_t what = va_arg(args, atom_t);
+
+      PL_unify_term(formal,
+		    PL_FUNCTOR, FUNCTOR_representation_error1,
+		      PL_ATOM, what);
+      break;
+    }
+  case ERR_NOT_IMPLEMENTED_PROC:
+    { const char *name = va_arg(args, const char *);
+      int arity = va_arg(args, int);
+
+      PL_unify_term(formal,
+		    PL_FUNCTOR, FUNCTOR_not_implemented2,
+		    PL_ATOM, ATOM_procedure,
+		    PL_FUNCTOR, FUNCTOR_divide2,
+		    PL_CHARS, name,
+		    PL_INT, arity);
+      break;
+    }
+  case ERR_EXISTENCE:
+    { atom_t type = va_arg(args, atom_t);
+      term_t obj  = va_arg(args, term_t);
+
+      PL_unify_term(formal,
+			PL_FUNCTOR, FUNCTOR_existence_error2,
+			  PL_ATOM, type,
+			  PL_TERM, obj);
+
+      break;
+    }
+  case ERR_PERMISSION:
+    { atom_t type = va_arg(args, atom_t);
+      atom_t op   = va_arg(args, atom_t);
+      term_t obj  = va_arg(args, term_t);
+
+      PL_unify_term(formal,
+			PL_FUNCTOR, FUNCTOR_permission_error3,
+			  PL_ATOM, type,
+			  PL_ATOM, op,
+			  PL_TERM, obj);
+
+      break;
+    }
+  case ERR_SYSCALL:
+    { const char *op = va_arg(args, const char *);
+
+      if ( !msg )
+	msg = op;
+
+      switch(errno)
+      { case ENOMEM:
+	  PL_unify_term(formal,
+			PL_FUNCTOR, FUNCTOR_resource_error1,
+			  PL_ATOM, ATOM_no_memory);
+	  break;
+	default:
+	  PL_unify_atom(formal, ATOM_system_error);
+	  break;
+      }
+
+      break;
+    }
+  case ERR_TIMEOUT:
+    { atom_t op   = va_arg(args, atom_t);
+      term_t obj  = va_arg(args, term_t);
+
+      PL_unify_term(formal,
+			PL_FUNCTOR, FUNCTOR_timeout_error2,
+			  PL_ATOM, op,
+			  PL_TERM, obj);
+
+      break;
+    }
+    case ERR_FILE_OPERATION:
+    { atom_t action = va_arg(args, atom_t);
+      atom_t type   = va_arg(args, atom_t);
+      term_t file   = va_arg(args, term_t);
+
+      switch(errno)
+      { case EACCES:
+	  PL_unify_term(formal,
+			PL_FUNCTOR, FUNCTOR_permission_error3,
+			  PL_ATOM, action,
+			  PL_ATOM, type,
+			  PL_TERM, file);
+	  break;
+	case EMFILE:
+	case ENFILE:
+	  PL_unify_term(formal,
+			PL_FUNCTOR, FUNCTOR_resource_error1,
+			  PL_ATOM, ATOM_max_files);
+	  break;
+#ifdef EPIPE
+	case EPIPE:
+	  if ( !msg )
+	    msg = "Broken pipe";
+	  /*FALLTHROUGH*/
+#endif
+	default:			/* what about the other cases? */
+	  PL_unify_term(formal,
+			PL_FUNCTOR, FUNCTOR_existence_error2,
+			  PL_ATOM, type,
+			  PL_TERM, file);
+	  break;
+      }
+
+      break;
+    }
+  case ERR_NOMEM:
+    { PL_unify_term(formal,
+		    PL_FUNCTOR, FUNCTOR_resource_error1,
+		      PL_ATOM, ATOM_no_memory);
+
+      break;
+    }
+  case ERR_EVALUATION:
+    { atom_t what = va_arg(args, atom_t);
+
+      PL_unify_term(formal,
+		    PL_FUNCTOR, FUNCTOR_evaluation_error1,
+		      PL_ATOM, what);
+      break;
+    }
+    case ERR_STREAM_OP:
+    { atom_t action = va_arg(args, atom_t);
+      term_t stream = va_arg(args, term_t);
+
+      rc = PL_unify_term(formal,
+			 PL_FUNCTOR, FUNCTOR_io_error2,
+			   PL_ATOM, action,
+			   PL_TERM, stream);
+      break;
+    }
+    case ERR_FORMAT:
+    { const char *s = va_arg(args, const char*);
+
+      rc = PL_unify_term(formal,
+			 PL_FUNCTOR_CHARS, "format", 1,
+			   PL_CHARS, s);
+      break;
+    }
+    case ERR_FORMAT_ARG:
+    { const char *s = va_arg(args, const char*);
+      term_t arg = va_arg(args, term_t);
+
+      rc = PL_unify_term(formal,
+			 PL_FUNCTOR_CHARS, "format_argument_type", 2,
+			   PL_CHARS, s,
+			   PL_TERM, arg);
+      break;
+    }
+
+  default:
+    fprintf(stderr, "unimplemented SWI error %d\n",id);
+    goto err_instantiation;
+  }
+  va_end(args);
+  if (!pred) {
+    pred = Yap_GetCurrentPredName();
+    arity = Yap_GetCurrentPredArity();
+  }
+  if ( pred )
+    { PL_unify_term(predterm,
+		    PL_FUNCTOR, FUNCTOR_divide2,
+		    PL_CHARS, pred,
+		    PL_INT, arity);
+    }
+  if (!rc) {
+    fatalError("Cannot report error: no memory");
+  }
+  if ( msg )
+    {
+      rc = PL_put_atom_chars(msgterm, msg);
+    }
+  rc = PL_unify_term(swi,
+		PL_FUNCTOR, FUNCTOR_context2,
+		PL_TERM, predterm,
+		PL_TERM, msgterm);
+  rc = PL_unify_term(except,
+		PL_FUNCTOR, FUNCTOR_error2,
+		PL_TERM, formal,
+		PL_TERM, swi);
+  rc = PL_raise_exception(except);
+  return rc;
+}
+

library/dialect/swi/os/pl-error.h

@@ -0,0 +1,94 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_ERROR_H
+#define PL_ERROR_H 1
+
+#ifndef COMMON
+#define COMMON(type) extern type
+#endif
+
+typedef enum
+{ ERR_NO_ERROR = 0,
+				/* Used in os-directory and maybe elsewhere */
+  ERR_DOMAIN,			/* atom_t domain, term_t value */
+  ERR_EXISTENCE,		/* atom_t type, term_t obj */
+  ERR_FILE_OPERATION,		/* atom_t action, atom_t type, term_t */
+  ERR_FORMAT,			/* message */
+  ERR_FORMAT_ARG,		/* seq, term */
+  ERR_INSTANTIATION,		/* void */
+  ERR_NOMEM,			/* void */
+  ERR_NOT_IMPLEMENTED,		/* const char *what */
+  ERR_PERMISSION,		/* atom_t type, atom_t op, term_t obj*/
+  ERR_REPRESENTATION,		/* atom_t what */
+  ERR_RESOURCE,			/* atom_t resource */
+  ERR_SHELL_FAILED,		/* term_t command */
+  ERR_SHELL_SIGNALLED,		/* term_t command, int signal */
+  ERR_STREAM_OP,		/* atom_t action, term_t obj */
+  ERR_SYSCALL,			/* void */
+  ERR_TIMEOUT,			/* op, object */
+  ERR_TYPE,			/* atom_t expected, term_t value */
+  ERR_UNINSTANTIATION,		/* int argn, term_t term */
+
+				/* Only used on SWI-Prolog itself */
+  ERR_AR_OVERFLOW,		/* void */
+  ERR_AR_TYPE,			/* atom_t expected, Number value */
+  ERR_AR_DOMAIN,		/* atom_t domain, Number value */
+  ERR_AR_UNDEF,			/* void */
+  ERR_AR_UNDERFLOW,		/* void */
+  ERR_PTR_TYPE,			/* atom_t expected, Word value */
+  ERR_BUSY,			/* mutexes */
+  ERR_CHARS_TYPE,		/* char *, term */
+  ERR_CLOSED_STREAM,		/* IOSTREAM * */
+  ERR_DDE_OP,			/* op, error */
+  ERR_DIV_BY_ZERO,		/* void */
+  ERR_EVALUATION,		/* atom_t what */
+  ERR_FAILED,			/* predicate_t proc */
+  ERR_MODIFY_STATIC_PROC,	/* predicate_t proc */
+  ERR_MODIFY_THREAD_LOCAL_PROC,	/* Procedure proc */
+  ERR_NOT_EVALUABLE,		/* functor_t func */
+  ERR_NOT_IMPLEMENTED_PROC,	/* name, arity */
+  ERR_IMPORT_PROC,		/* proc, dest, [already-from] */
+  ERR_OCCURS_CHECK,		/* Word, Word */
+  ERR_PERMISSION_PROC,		/* op, type, Definition */
+  ERR_SHARED_OBJECT_OP,		/* op, error */
+  ERR_SIGNALLED,		/* int sig, char *name */
+  ERR_SYNTAX,			/* what */
+  ERR_UNDEFINED_PROC		/* Definition def */
+} PL_error_code;
+
+#define MSG_ERRNO		((char *)(-1))
+
+COMMON(int)		PL_error(const char *pred, int arity, const char *msg,
+				 PL_error_code id, ...);
+COMMON(int)		PL_no_memory(void);
+COMMON(int)		printMessage(atom_t severity, ...);
+#ifdef ARG_LD
+COMMON(int)		PL_get_atom_ex__LD(term_t t, atom_t *a ARG_LD);
+#endif
+COMMON(int)		PL_get_module_ex(term_t name, module_t *m);
+COMMON(int)		PL_get_arg_ex(int n, term_t term, term_t arg);
+COMMON(int)             check_float(double f);
+
+#endif

library/dialect/swi/os/pl-file.h

@@ -0,0 +1,82 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_FILE_H_INCLUDED
+#define PL_FILE_H_INCLUDED
+
+typedef enum
+{ ST_FALSE = -1,			/* Do not check stream types */
+  ST_LOOSE = 0,				/* Default: accept latin-1 for binary */
+  ST_TRUE  = 1				/* Strict checking */
+} st_check;
+
+/* pl-file.c */
+COMMON(void)		initIO(void);
+COMMON(void)		dieIO(void);
+COMMON(void)		closeFiles(int all);
+COMMON(int)		openFileDescriptors(unsigned char *buf, int size);
+COMMON(void)		protocol(const char *s, size_t n);
+COMMON(int)		getTextInputStream__LD(term_t t, IOSTREAM **s ARG_LD);
+COMMON(int)		getBinaryInputStream__LD(term_t t, IOSTREAM **s ARG_LD);
+COMMON(int)		getTextOutputStream__LD(term_t t, IOSTREAM **s ARG_LD);
+COMMON(int)		getBinaryOutputStream__LD(term_t t, IOSTREAM **s ARG_LD);
+COMMON(int)	        reportStreamError(IOSTREAM *s);
+COMMON(int)		streamStatus(IOSTREAM *s);
+COMMON(int)		setFileNameStream(IOSTREAM *s, atom_t name);
+COMMON(atom_t)		fileNameStream(IOSTREAM *s);
+COMMON(int)		getSingleChar(IOSTREAM *s, int signals);
+COMMON(bool)		readLine(IOSTREAM *in, IOSTREAM *out, char *buffer);
+COMMON(int)		LockStream(void);
+COMMON(int)		UnlockStream(void);
+COMMON(IOSTREAM *)	PL_current_input(void);
+COMMON(IOSTREAM *)	PL_current_output(void);
+COMMON(int)		pl_see(term_t f);
+COMMON(int)		pl_seen(void);
+COMMON(int)		seeString(const char *s);
+COMMON(int)		seeingString(void);
+COMMON(int)		seenString(void);
+COMMON(bool)		tellString(char **s, size_t *size, IOENC enc);
+COMMON(bool)		toldString(void);
+COMMON(void)		prompt1(atom_t prompt);
+COMMON(atom_t)		PrologPrompt(void);
+COMMON(int)		streamNo(term_t spec, int mode);
+COMMON(void)		release_stream_handle(term_t spec);
+COMMON(int)		unifyTime(term_t t, time_t time);
+#ifdef __WINDOWS__
+COMMON(word)		pl_make_fat_filemap(term_t dir);
+#endif
+COMMON(int)		PL_unify_stream_or_alias(term_t t, IOSTREAM *s);
+COMMON(void)		pushOutputContext(void);
+COMMON(void)		popOutputContext(void);
+COMMON(IOENC)		atom_to_encoding(atom_t a);
+COMMON(atom_t)		encoding_to_atom(IOENC enc);
+COMMON(int)		setupOutputRedirect(term_t to,
+					    redir_context *ctx,
+					    int redir);
+COMMON(int)		closeOutputRedirect(redir_context *ctx);
+COMMON(void)		discardOutputRedirect(redir_context *ctx);
+COMMON(int)		push_input_context(atom_t type);
+COMMON(int)		pop_input_context(void);
+
+#endif /*PL_FILE_H_INCLUDED*/

library/dialect/swi/os/pl-files.h

@@ -0,0 +1,41 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2008, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_FILES_H_INCLUDED
+#define PL_FILES_H_INCLUDED
+
+#define ACCESS_EXIST	0		/* AccessFile() modes */
+#define ACCESS_EXECUTE	1
+#define ACCESS_READ	2
+#define ACCESS_WRITE	4
+
+COMMON(void)		initFiles(void);
+COMMON(int)		LastModifiedFile(const char *f, double *t);
+COMMON(int)		RemoveFile(const char *path);
+COMMON(int)		AccessFile(const char *path, int mode);
+COMMON(char *)		DeRefLink(const char *link, char *buf);
+COMMON(int)		ExistsFile(const char *path);
+COMMON(int)		ExistsDirectory(const char *path);
+
+#endif /*PL_FILES_H_INCLUDED*/

library/dialect/swi/os/pl-glob.c

@@ -0,0 +1,699 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+			      VU University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+#include "pl-ctype.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef O_XOS
+# include "windows/dirent.h"
+#else
+#if HAVE_DIRENT_H
+# include <dirent.h>
+#else
+# define dirent direct
+# 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
+#endif /*O_XOS*/
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+#ifdef HAVE_SYS_PARAM_H
+#include <sys/param.h>
+#endif
+
+#define O_EXPANDS_TESTS_EXISTS 1
+
+#ifndef IS_DIR_SEPARATOR
+#define IS_DIR_SEPARATOR(c)	((c) == '/')
+#endif
+
+#define char_to_int(c)	(0xff & (int)(c))
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Unix Wildcard Matching.  Recognised:
+
+  ?		matches one arbitrary character
+  *		matches any number of any character
+  [xa-z]	matches x and a-z
+  {p1,p2}	matches pattern p1 or p2
+
+  backslash (\) escapes a character.
+
+First the pattern is compiled into an intermediate representation.  Next
+this intermediate representation is matched  against  the  target.   The
+non-ascii  characters  are  used  to  store  control  sequences  in  the
+intermediate representation:
+
+  ANY		Match any character
+  STAR		Match (possibly empty) sequence
+  ALT <offset>	Match, if fails, continue at <pc> + offset
+  JMP <offset>	Jump <offset> instructions
+  ANYOF		Next 16 bytes are bitmap
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define MAXCODE 1024
+
+#define ANY	128
+#define STAR	129
+#define ALT	130
+#define JMP	131
+#define ANYOF	132
+#define EXIT	133
+
+#define NOCURL	0
+#define CURL	1
+
+typedef unsigned char matchcode;
+
+typedef struct
+{ int		size;
+  matchcode	code[MAXCODE];
+} compiled_pattern;
+
+static char	*compile_pattern(compiled_pattern *, char *, int);
+static bool	match_pattern(matchcode *, char *);
+
+#define Output(c)	{ if ( Out->size > MAXCODE-1 ) \
+			  { warning("pattern too large"); \
+			    return (char *) NULL; \
+			  } \
+			  Out->code[Out->size++] = c; \
+			}
+
+static inline void
+setMap(matchcode *map, int c)
+{ GET_LD
+
+  if ( !truePrologFlag(PLFLAG_FILE_CASE) )
+    c = makeLower(c);
+
+  map[(c)/8] |= 1 << ((c) % 8);
+}
+
+
+static bool
+compilePattern(char *p, compiled_pattern *cbuf)
+{ cbuf->size = 0;
+  if ( compile_pattern(cbuf, p, NOCURL) == (char *) NULL )
+    fail;
+
+  succeed;
+}
+
+
+static char *
+compile_pattern(compiled_pattern *Out, char *p, int curl)
+{ int c;
+
+  for(;;)
+  { switch(c = char_to_int(*p++))
+    { case EOS:
+	break;
+      case '\\':
+	Output(*p == EOS ? '\\' : (*p & 0x7f));
+	if (*p == EOS )
+	  break;
+	p++;
+	continue;
+      case '?':
+	Output(ANY);
+	continue;
+      case '*':
+	Output(STAR);
+	continue;
+      case '[':
+	{ matchcode *map;
+	  int n;
+
+	  Output(ANYOF);
+	  map = &Out->code[Out->size];
+	  Out->size += 16;
+	  if ( Out->size >= MAXCODE )
+	  { warning("Pattern too intptr_t");
+	    return (char *) NULL;
+	  }
+
+	  for( n=0; n < 16; n++)
+	    map[n] = 0;
+
+	  for(;;)
+	  { switch( c = *p++ )
+	    { case '\\':
+		if ( *p == EOS )
+		{ warning("Unmatched '['");
+		  return (char *)NULL;
+		}
+		setMap(map, *p);
+		p++;
+		continue;
+	      case ']':
+		break;
+	      default:
+		if ( p[-1] != ']' && p[0] == '-' && p[1] != ']' )
+		{ int chr;
+
+		  for ( chr=p[-1]; chr <= p[1]; chr++ )
+		    setMap(map, chr);
+		  p += 2;
+		} else
+		  setMap(map, c);
+		continue;
+	    }
+	    break;
+	  }
+
+	  continue;
+	}
+      case '{':
+	{ int ai, aj = -1;
+
+	  for(;;)
+	  { Output(ALT); ai = Out->size; Output(0);
+	    if ( (p = compile_pattern(Out, p, CURL)) == (char *) NULL )
+	      return (char *) NULL;
+	    if ( aj > 0 )
+	      Out->code[aj] = Out->size - aj;
+	    if ( *p == ',' )
+	    { Output(JMP); aj = Out->size; Output(0);
+	      Out->code[ai] = Out->size - ai;
+	      Output(ALT); ai = Out->size; Output(0);
+	      p++;
+	    } else if ( *p == '}' )
+	    { p++;
+	      break;
+	    } else
+	    { warning("Unmatched '{'");
+	      return (char *) NULL;
+	    }
+	  }
+
+	  continue;
+	}
+      case ANY:
+      case STAR:
+      case ALT:
+      case JMP:
+      case ANYOF:
+      case EXIT:
+	PL_error(NULL, 0, "Reserved character",
+		 ERR_REPRESENTATION, ATOM_pattern);
+	return NULL;
+      case '}':
+      case ',':
+	if ( curl == CURL )
+	{ p--;
+	  return p;
+	}
+	/*FALLTHROUGH*/
+      default:
+      { GET_LD
+
+        if ( !truePrologFlag(PLFLAG_FILE_CASE) )
+	  c = makeLower(c);
+	Output(c);
+	continue;
+      }
+    }
+
+    Output(EXIT);
+    return p;
+  }
+}
+
+
+static inline bool
+matchPattern(char *s, compiled_pattern *cbuf)
+{ return match_pattern(cbuf->code, s);
+}
+
+
+static bool
+match_pattern(matchcode *p, char *str)
+{ matchcode c;
+  matchcode *s = (matchcode *) str;
+
+  for(;;)
+  { switch( c = *p++ )
+    { case EXIT:
+	  return (*s == EOS ? TRUE : FALSE);
+      case ANY:						/* ? */
+	  if ( *s == EOS )
+	    fail;
+	  s++;
+	  continue;
+      case ANYOF:					/* [...] */
+        { GET_LD
+	  matchcode c2 = *s;
+
+	  if ( !truePrologFlag(PLFLAG_FILE_CASE) )
+	    c2 = makeLower(c2);
+
+	  if ( p[c2 / 8] & (1 << (c2 % 8)) )
+	  { p += 16;
+	    s++;
+	    continue;
+	  }
+	  fail;
+	}
+      case STAR:					/* * */
+	  do
+	  { if ( match_pattern(p, (char *)s) )
+	      succeed;
+	  } while( *s++ );
+	  fail;
+      case JMP:						/* { ... } */
+	  p += *p;
+	  continue;
+      case ALT:
+	  if ( match_pattern(p+1, (char *)s) )
+	    succeed;
+	  p += *p;
+	  continue;
+      default:						/* character */
+      { GET_LD
+
+	  if ( c == *s ||
+	       (!truePrologFlag(PLFLAG_FILE_CASE) && c == makeLower(*s)) )
+	  { s++;
+	    continue;
+	  }
+          fail;
+      }
+    }
+  }
+}
+
+
+/** wildcard_match(+Pattern, +Name) is semidet.
+*/
+
+static
+PRED_IMPL("wildcard_match", 2, wildcard_match, 0)
+{ char *p, *s;
+  compiled_pattern buf;
+
+  if ( !PL_get_chars(A1, &p, CVT_ALL|CVT_EXCEPTION) ||
+       !PL_get_chars(A2,  &s, CVT_ALL|CVT_EXCEPTION) )
+    fail;
+
+  if ( compilePattern(p, &buf) )
+  { return matchPattern(s, &buf);
+  }
+
+  return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_pattern, A1);
+}
+
+
+		 /*******************************
+		 *	EXPAND_FILE_NAME/2	*
+		 *******************************/
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Wildcart expansion of a pattern to a list   of files. This code uses two
+`buffers'  for  storing  the   intermediate    results   while  limiting
+fragmentation. The `strings' buffer contains  all strings generated. The
+files contains indices in the `strings' buffer  pointing to the start of
+strings.  The indices in the range [start,end) are valid.
+
+First  this  set  is   filled   with    the   empty   string.  Next  the
+directory-segment with the first wildcart is   located.  If found, we go
+through the current set, adding the segments without wildcarts, applying
+the wildcart on the directory and adding   everything  found to the set.
+The old set is deleted by incrementing info.start.
+
+If we are at the end, we add the remaining non-wildcart segments to each
+element of the set, deleting it if the result does not exits.
+
+Finally we sort the result.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+typedef struct
+{ tmp_buffer	files;			/* our files */
+  tmp_buffer	strings;		/* our strings */
+  int		start;			/* 1-st valid entry of files */
+  int		end;			/* last valid entry of files */
+} glob_info, *GlobInfo;
+
+#undef isspecial			/* play safe */
+#define isspecial(c) \
+	((c) == '[' || (c) == '{' || (c) == '?' || (c) == '*')
+
+static void
+free_expand_info(GlobInfo info)
+{ discardBuffer(&info->files);
+  discardBuffer(&info->strings);
+}
+
+
+static void
+add_path(const char *path, GlobInfo info)
+{ int idx = (int)entriesBuffer(&info->strings, char);
+  size_t n = strlen(path)+1;
+
+  addMultipleBuffer(&info->strings, path, n, char);
+  addBuffer(&info->files, idx, int);
+  info->end++;
+}
+
+
+static const char *
+expand_str(GlobInfo info, int at)
+{ char *s = &fetchBuffer(&info->strings, at, char);
+
+  return (const char *)s;
+}
+
+
+static const char *
+expand_entry(GlobInfo info, int idx)
+{ int at = fetchBuffer(&info->files, idx, int);
+
+  return expand_str(info, at);
+}
+
+
+static void
+un_escape(char *to, const char *from, const char *end)
+{ while( from < end )
+  { if ( *from == '\\' && (isspecial(from[1]) || from[1] == '\\') )
+      from++;
+    *to++ = *from++;
+  }
+  *to = EOS;
+}
+
+
+static int
+expand(const char *pattern, GlobInfo info)
+{ const char *pat = pattern;
+  compiled_pattern cbuf;
+  char prefix[MAXPATHLEN];		/* before first pattern */
+  char patbuf[MAXPATHLEN];		/* pattern buffer */
+  size_t prefix_len;
+  int end, dot;
+
+  initBuffer(&info->files);
+  initBuffer(&info->strings);
+  info->start = 0;
+  info->end = 0;
+
+  add_path("", info);
+
+  for(;;)
+  { const char *s = pat, *head = pat, *tail;
+
+    for(;;)
+    { int c;
+
+      switch( (c=*s++) )
+      { case EOS:
+	  if ( s > pat )		/* something left and expanded */
+	  { size_t prefix_len;
+
+	    un_escape(prefix, pat, s);
+	    prefix_len = strlen(prefix);
+
+	    end = info->end;
+	    for( ; info->start < end; info->start++ )
+	    { char path[MAXPATHLEN];
+	      const char *entry = expand_entry(info, info->start);
+	      size_t plen = strlen(entry);
+
+	      if ( plen+prefix_len+2 <= MAXPATHLEN )
+	      { strcpy(path, entry);
+		if ( prefix[0] && plen > 0 && path[plen-1] != '/' )
+		  path[plen++] = '/';
+		strcpy(&path[plen], prefix);
+		if ( end == 1 || AccessFile(path, ACCESS_EXIST) )
+		  add_path(path, info);
+	      }
+	    }
+	  }
+	  succeed;
+	case '[':				/* meta characters: expand */
+	case '{':
+	case '?':
+	case '*':
+	  break;
+	case '\\':
+	  if ( isspecial(*s) )
+	  { s++;
+	    continue;
+	  }
+	/*FALLTHROUGH*/
+	default:
+	  if ( IS_DIR_SEPARATOR(c) )
+	    head = s;
+	  continue;
+      }
+      break;
+    }
+
+    for( tail=s; *tail && !IS_DIR_SEPARATOR(*tail); tail++ )
+      ;
+
+/*  By now, head points to the start of the path holding meta characters,
+    while tail points to the tail:
+
+    ..../meta*path/....
+	 ^        ^
+       head     tail
+*/
+    un_escape(prefix, pat, head);
+    un_escape(patbuf, head, tail);
+    prefix_len = strlen(prefix);
+
+    if ( !compilePattern(patbuf, &cbuf) )	/* syntax error */
+      fail;
+    dot = (patbuf[0] == '.');			/* do dots as well */
+
+    end = info->end;
+
+    for(; info->start < end; info->start++)
+    { DIR *d;
+      struct dirent *e;
+      char path[MAXPATHLEN];
+      char tmp[MAXPATHLEN];
+      const char *current = expand_entry(info, info->start);
+      size_t clen = strlen(current);
+
+      if ( clen+prefix_len+1 > sizeof(path) )
+	continue;
+
+      strcpy(path, current);
+      strcpy(&path[clen], prefix);
+
+      if ( (d=opendir(path[0] ? OsPath(path, tmp) : ".")) )
+      { size_t plen = clen+prefix_len;
+
+	if ( plen > 0 && path[plen-1] != '/' )
+	  path[plen++] = '/';
+
+	for(e=readdir(d); e; e = readdir(d))
+	{
+#ifdef __MSDOS__
+	  strlwr(e->d_name);
+#endif
+	  if ( (dot || e->d_name[0] != '.') &&
+	       matchPattern(e->d_name, &cbuf) )
+	  { char newp[MAXPATHLEN];
+
+	    if ( plen+strlen(e->d_name)+1 < sizeof(newp) )
+	    { strcpy(newp, path);
+	      strcpy(&newp[plen], e->d_name);
+	      add_path(newp, info);
+	    }
+	  }
+	}
+	closedir(d);
+      }
+    }
+
+    pat = tail;
+    if ( IS_DIR_SEPARATOR(*pat) )
+      pat++;
+  }
+}
+
+
+static int
+compareBagEntries(const void *a1, const void *a2)
+{ GET_LD
+  GlobInfo info = LD->glob_info;
+  int i1 = *(int *)a1;
+  int i2 = *(int *)a2;
+  const char *s1, *s2;
+
+  s1 = expand_str(info, i1);
+  s2 = expand_str(info, i2);
+
+  if ( truePrologFlag(PLFLAG_FILE_CASE) )
+    return mbscoll(s1, s2);
+  else
+    return mbscasecoll(s1, s2);
+}
+
+
+static void
+sort_expand(GlobInfo info)
+{ GET_LD
+  int *ip = &fetchBuffer(&info->files, info->start, int);
+  int is = info->end - info->start;
+
+  LD->glob_info = info;
+  qsort(ip, is, sizeof(int), compareBagEntries);
+}
+
+/**
+
+	@addgroup
+
+	\pred expand_file_name(+ _WildCard_,- _List_)
+
+
+	This is an SWI-Prolog built-in that unifies  _List_ with a sorted list of
+	files or directories matching  _WildCard_. The normal Unix wildcard
+	constructs <tt>?</tt>, <tt>\\\*</tt>, <tt>[ ... ]</tt> and <tt>{...}</tt> are recognised. The
+	interpretation of <tt>{...}</tt> is interpreted slightly different from the
+	C shell (csh(1)). The comma separated argument can be arbitrary
+	patterns, including <tt>{...}</tt> patterns. The empty pattern is legal as
+	well: <tt>{.pl,}</tt> matches either <tt>.pl</tt> or the empty string.
+
+	If the pattern contains wildcard characters, only existing files and
+	directories are returned. Expanding a <em>pattern'</em> without wildcard
+	characters returns the argument, regardless on whether or not it exists.
+
+	Before expanding wildcards, the construct $var is expanded to the value
+	of the environment variable var and a possible leading ~ character is
+	expanded to the user's home directory. In Windows, the home directory is
+	determined as follows: if the environment variable `HOME` exists,
+	this is used. If the variables `HOMEDRIVE` and `HOMEPATH`
+	exist (Windows-NT), these are used. At initialisation, the system will
+	set the environment variable `HOME` to point to the YAP home
+	directory if neither `HOME` nor `HOMEPATH` and
+	`HOMEDRIVE` are defined.
+
+*/
+static
+PRED_IMPL("expand_file_name", 2, expand_file_name, 0)
+{ PRED_LD
+  char spec[MAXPATHLEN];
+  char *s;
+  glob_info info;
+  term_t l    = PL_copy_term_ref(A2);
+  term_t head = PL_new_term_ref();
+  int i;
+
+  if ( !PL_get_chars(A1, &s, CVT_ALL|REP_FN|CVT_EXCEPTION) )
+    fail;
+  if ( strlen(s) > sizeof(spec)-1 )
+    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
+		    ATOM_max_path_length);
+
+  if ( !expandVars(s, spec, sizeof(spec)) )
+    fail;
+  if ( !expand(spec, &info) )
+    goto failout;
+  sort_expand(&info);
+
+  for( i = info.start; i< info.end; i++ )
+  { const char *e = expand_entry(&info, i);
+
+    if ( !PL_unify_list(l, head, l) ||
+	 !PL_unify_chars(head, PL_ATOM|REP_FN, -1, e) )
+      goto failout;
+  }
+
+  if ( !PL_unify_nil(l) )
+  { failout:
+    free_expand_info(&info);
+    fail;
+  }
+
+  free_expand_info(&info);
+  succeed;
+}
+
+
+/** directory_files(+Dir, -Files) is det.
+
+Files is a list of atoms that describe the entries in Dir.
+*/
+
+static
+PRED_IMPL("directory_files", 2, directory_files, 0)
+{ PRED_LD
+  char *dname;
+  DIR *dir;
+
+  if ( !PL_get_file_name(A1, &dname, PL_FILE_READ|PL_FILE_OSPATH) )
+    return FALSE;
+
+  if ( (dir=opendir(dname)) )
+  { struct dirent *e;
+    term_t tail = PL_copy_term_ref(A2);
+    term_t head = PL_new_term_ref();
+
+    for(e=readdir(dir); e; e = readdir(dir))
+    { PL_put_variable(head);
+      if ( PL_handle_signals() < 0 ||
+	   !PL_unify_list(tail, head, tail) ||
+	   !PL_unify_chars(head, PL_ATOM|REP_FN, (size_t)-1, e->d_name) )
+      { closedir(dir);
+	return FALSE;
+      }
+    }
+    closedir(dir);
+
+    return PL_unify_nil(tail);
+  }
+
+  return PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
+		  ATOM_open, ATOM_directory, A1);
+}
+
+
+		 /*******************************
+		 *      PUBLISH PREDICATES	*
+		 *******************************/
+
+BeginPredDefs(glob)
+  PRED_DEF("expand_file_name", 2, expand_file_name, 0)
+  PRED_DEF("wildcard_match",   2, wildcard_match,   0)
+  PRED_DEF("directory_files",  2, directory_files,  0)
+EndPredDefs

library/dialect/swi/os/pl-locale.c

@@ -0,0 +1,943 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2013, VU University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+/** @defgroup SetLocale Localization Support
+  * @ingroup InputOutput
+  * @{
+  *
+  * This code includes support for localization, that is, the ability to support
+  * different languages and representation formats.
+  *
+  */
+#include "pl-incl.h"
+#include "pl-locale.h"
+
+#if defined(__sun) || __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1070
+#undef HAVE_WCSDUP			/* No prototype, so better use our own */
+#endif
+
+#ifdef O_LOCALE
+
+#include <locale.h>
+
+#define LOCK()   PL_LOCK(L_LOCALE)	/* MT locking */
+#define UNLOCK() PL_UNLOCK(L_LOCALE)
+
+#undef LD				/* fetch LD once per function */
+#define LD LOCAL_LD
+
+#define LSTR_MAX 16
+
+#ifndef HAVE_LOCALECONV
+typedef struct
+{ char *decimal_point;
+  char *thousands_sep;
+  char *grouping;
+} lconv;
+
+static struct lconv defl =
+  { ".",
+    ",",
+    "\003\003"
+  };
+
+struct lconv *
+localeconv(void)
+{
+  return &defl;
+}
+#endif
+
+
+#ifndef HAVE_WCSDUP
+static wchar_t *
+my_wcsdup(const wchar_t *in)
+{ wchar_t *copy = malloc((wcslen(in)+1)*sizeof(wchar_t));
+
+  if ( copy )
+    return wcscpy(copy, in);
+
+  return NULL;
+}
+#define wcsdup(ws) my_wcsdup(ws)
+#endif
+
+
+static wchar_t *
+ls_to_wcs(const char *in, const wchar_t *on_error)
+{ wchar_t buf[LSTR_MAX];
+  mbstate_t state;
+
+  memset(&state, 0, sizeof(state));
+  mbsrtowcs(buf, &in, LSTR_MAX, &state);
+  if ( in == NULL )
+  { return wcsdup(buf);
+  } else
+  { Sdprintf("Illegal locale string: %s\n", in);
+    return wcsdup(on_error);
+  }
+}
+
+
+static int
+init_locale_strings(PL_locale *l, struct lconv *conv)
+{ if ( conv )
+  { l->decimal_point = ls_to_wcs(conv->decimal_point, L".");
+    l->thousands_sep = ls_to_wcs(conv->thousands_sep, L",");
+    l->grouping      = strdup(conv->grouping);
+
+    return TRUE;
+  } else
+  { l->decimal_point = wcsdup(L".");
+    l->thousands_sep = wcsdup(L",");
+    l->grouping      = strdup("\003");
+
+    return FALSE;
+  }
+}
+
+
+static PL_locale *
+new_locale(PL_locale *proto)
+{ PL_locale *new = PL_malloc(sizeof(*new));
+
+  if ( new )
+  { memset(new, 0, sizeof(*new));
+    new->magic = LOCALE_MAGIC;
+
+    if ( proto )
+    { new->decimal_point = wcsdup(proto->decimal_point);
+      new->thousands_sep = wcsdup(proto->thousands_sep);
+      new->grouping      = strdup(proto->grouping);
+    } else
+    { init_locale_strings(new, localeconv());
+    }
+  }
+
+  return new;
+}
+
+
+static void
+free_locale_strings(PL_locale *l)
+{ free(l->decimal_point);
+  free(l->thousands_sep);
+  free(l->grouping);
+}
+
+static void
+free_locale(PL_locale *l)
+{ if ( l )
+  { free_locale_strings(l);
+
+    if ( l->alias )
+      PL_unregister_atom(l->alias);
+
+    PL_free(l);
+  }
+}
+
+static void
+update_locale(PL_locale *l, int category, const char *locale)
+{ free_locale_strings(l);
+  init_locale_strings(l, localeconv());
+}
+
+
+static int
+alias_locale(PL_locale *l, atom_t alias)
+{ int rc;
+
+  LOCK();
+
+  if ( !GD->locale.localeTable )
+    GD->locale.localeTable = newHTable(16);
+
+  if ( addHTable(GD->locale.localeTable, (void*)alias, l) )
+  { l->alias = alias;
+    PL_register_atom(alias);
+    rc = TRUE;
+  } else
+  { GET_LD
+    term_t obj = PL_new_term_ref();
+
+    PL_put_atom(obj, alias);
+    rc = PL_error("locale_create", 2, "Alias name already taken",
+		  ERR_PERMISSION, ATOM_create, ATOM_locale, obj);
+  }
+  UNLOCK();
+
+  return rc;
+}
+
+
+		 /*******************************
+		 *	  LOCALE BLOB		*
+		 *******************************/
+
+typedef struct locale_ref
+{ PL_locale	*data;
+} locale_ref;
+
+
+static int
+write_locale_ref(IOSTREAM *s, atom_t aref, int flags)
+{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
+  (void)flags;
+
+  Sfprintf(s, "<locale>(%p)", ref->data);
+
+  return TRUE;
+}
+
+
+static void
+acquire_locale_ref(atom_t aref)
+{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
+
+  (void)ref;
+}
+
+
+static int
+release_locale_ref(atom_t aref)
+{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
+
+  LOCK();
+  if ( ref->data->references == 0 )
+    free_locale(ref->data);
+  else
+    ref->data->symbol = 0;
+  UNLOCK();
+
+  return TRUE;
+}
+
+
+static int
+save_locale_ref(atom_t aref, IOSTREAM *fd)
+{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
+  (void)fd;
+
+  return PL_warning("Cannot save reference to <locale>(%p)", ref->data);
+}
+
+
+static atom_t
+load_locale_ref(IOSTREAM *fd)
+{ (void)fd;
+
+  return PL_new_atom("<saved-locale-ref>");
+}
+
+
+static PL_blob_t locale_blob =
+{ PL_BLOB_MAGIC,
+  PL_BLOB_UNIQUE,
+  "locale",
+  release_locale_ref,
+  NULL,
+  write_locale_ref,
+  acquire_locale_ref,
+  save_locale_ref,
+  load_locale_ref
+};
+
+
+		 /*******************************
+		 *	   PROLOG HANDLE	*
+		 *******************************/
+
+int
+unifyLocale(term_t t, PL_locale *l, int alias)
+{ GET_LD
+  term_t b;
+
+  if ( l->alias && alias )
+    return PL_unify_atom(t, l->alias);
+
+  if ( l->symbol )
+    return PL_unify_atom(t, l->symbol);
+
+  if ( (b=PL_new_term_ref()) &&
+       PL_put_blob(b, &l, sizeof(l), &locale_blob) )
+  { PL_get_atom(b, &l->symbol);
+    assert(l->symbol);
+    return PL_unify(t, b);
+  }
+
+  return FALSE;
+}
+
+
+int
+getLocale(term_t t, PL_locale **lp)
+{ GET_LD
+  atom_t a;
+
+  if ( PL_get_atom(t, &a) )
+  { PL_locale *l = NULL;
+    PL_blob_t *bt;
+    locale_ref *ref;
+
+    if ( a == ATOM_current_locale )
+    { GET_LD
+
+      l = LD->locale.current;
+    } else if ( (ref=PL_blob_data(a, NULL, &bt)) && bt == &locale_blob )
+    { l = ref->data;
+    } else if ( GD->locale.localeTable )
+    { Symbol s;
+
+      if ( (s=lookupHTable(GD->locale.localeTable, (void*)a)) )
+	l = s->value;
+    }
+
+    if ( l )
+    { assert(l->magic == LOCALE_MAGIC);
+      *lp = acquireLocale(l);
+      return TRUE;
+    }
+  }
+
+  return FALSE;
+}
+
+
+int
+getLocaleEx(term_t t, PL_locale **lp)
+{ GET_LD
+
+  if ( getLocale(t, lp) )
+    return TRUE;
+
+  if ( PL_is_atom(t) )
+    return PL_existence_error("locale", t);
+  else
+    return PL_type_error("locale", t);
+}
+
+
+		 /*******************************
+		 *	 PROLOG BINDING		*
+		 *******************************/
+
+static int		/* locale_property(Mutex, alias(Name)) */
+locale_alias_property(PL_locale *l, term_t prop ARG_LD)
+{ if ( l->alias )
+    return PL_unify_atom(prop, l->alias);
+
+  return FALSE;
+}
+
+static int		/* locale_property(Locale, decimal_point(Atom)) */
+locale_decimal_point_property(PL_locale *l, term_t prop ARG_LD)
+{ if ( l->decimal_point && l->decimal_point[0] )
+    return PL_unify_wchars(prop, PL_ATOM, (size_t)-1, l->decimal_point);
+
+  return FALSE;
+}
+
+static int		/* locale_property(Locale, thousands_sep(Atom)) */
+locale_thousands_sep_property(PL_locale *l, term_t prop ARG_LD)
+{ if ( l->thousands_sep && l->thousands_sep[0] )
+    return PL_unify_wchars(prop, PL_ATOM, (size_t)-1, l->thousands_sep);
+
+  return FALSE;
+}
+
+static int		/* locale_property(Locale, grouping(List)) */
+locale_grouping_property(PL_locale *l, term_t prop ARG_LD)
+{ if ( l->grouping && l->grouping[0] )
+  { term_t tail = PL_copy_term_ref(prop);
+    term_t head = PL_new_term_ref();
+    char *s;
+
+    for(s=l->grouping; ; s++)
+    { if ( !PL_unify_list(tail, head, tail) )
+	return FALSE;
+      if ( s[1] == 0 || (s[1] == s[0] && s[2] == 0) )
+	return ( PL_unify_term(head, PL_FUNCTOR, FUNCTOR_repeat1,
+			       PL_INT, (int)s[0]) &&
+		 PL_unify_nil(tail)
+	       );
+      if ( s[0] == CHAR_MAX )
+	return PL_unify_nil(tail);
+      if ( !PL_unify_integer(head, s[0]) )
+	return FALSE;
+    }
+  }
+
+  return FALSE;
+}
+
+
+typedef struct
+{ functor_t functor;			/* functor of property */
+   int (*function)();			/* function to generate */
+} lprop;
+
+static const lprop lprop_list [] =
+{ { FUNCTOR_alias1,	    locale_alias_property },
+  { FUNCTOR_decimal_point1, locale_decimal_point_property },
+  { FUNCTOR_thousands_sep1, locale_thousands_sep_property },
+  { FUNCTOR_grouping1,      locale_grouping_property },
+  { 0,			    NULL }
+};
+
+typedef struct
+{ TableEnum e;				/* Enumerator on mutex-table */
+  PL_locale *l;				/* current locale */
+  const lprop *p;			/* Pointer in properties */
+  int enum_properties;			/* Enumerate the properties */
+} lprop_enum;
+
+
+static int
+get_prop_def(term_t t, atom_t expected, const lprop *list, const lprop **def)
+{ GET_LD
+  functor_t f;
+
+  if ( PL_get_functor(t, &f) )
+  { const lprop *p = list;
+
+    for( ; p->functor; p++ )
+    { if ( f == p->functor )
+      { *def = p;
+        return TRUE;
+      }
+    }
+
+    PL_error(NULL, 0, NULL, ERR_DOMAIN, expected, t);
+    return -1;
+  }
+
+  if ( PL_is_variable(t) )
+    return 0;
+
+  PL_error(NULL, 0, NULL, ERR_TYPE, expected, t);
+  return -1;
+}
+
+
+static int
+advance_lstate(lprop_enum *state)
+{ if ( state->enum_properties )
+  { state->p++;
+    if ( state->p->functor )
+      return TRUE;
+
+    state->p = lprop_list;
+  }
+  if ( state->e )
+  { Symbol s;
+
+    if ( (s = advanceTableEnum(state->e)) )
+    { state->l = s->value;
+
+      return TRUE;
+    }
+  }
+
+  return FALSE;
+}
+
+
+static void
+free_lstate(lprop_enum *state)
+{ if ( state->e )
+    freeTableEnum(state->e);
+  else if ( state->l )
+    releaseLocale(state->l);
+
+  freeForeignState(state, sizeof(*state));
+}
+
+
+static int
+get_atom_arg(term_t t, atom_t *a)
+{ GET_LD
+  term_t t2 = PL_new_term_ref();
+
+  return PL_get_arg(1, t, t2) && PL_get_atom(t2, a);
+}
+
+
+/** locale_property(?Locale, ?Property) is nondet.
+*/
+/// @memberof locale_property/2
+static
+PRED_IMPL("locale_property", 2, locale_property, PL_FA_NONDETERMINISTIC)
+{ PRED_LD
+  term_t locale = A1;
+  term_t property = A2;
+  lprop_enum statebuf;
+  lprop_enum *state = NULL;
+
+  switch( CTX_CNTRL )
+  { case FRG_FIRST_CALL:
+    { memset(&statebuf, 0, sizeof(statebuf));
+      state = &statebuf;
+
+      if ( PL_is_variable(locale) )
+      { switch( get_prop_def(property, ATOM_locale_property,
+			     lprop_list, &state->p) )
+	{ case 1:
+	  { atom_t alias;
+
+	    if ( state->p->functor == FUNCTOR_alias1 &&
+		 get_atom_arg(property, &alias) )
+	    { Symbol s;
+
+	      if ( (s=lookupHTable(GD->locale.localeTable, (void*)alias)) )
+		return unifyLocale(locale, s->value, FALSE);
+	      else
+		return FALSE;
+	    }
+	    state->e = newTableEnum(GD->locale.localeTable);
+	    goto enumerate;
+	  }
+	  case 0:
+	    state->e = newTableEnum(GD->locale.localeTable);
+	    state->p = lprop_list;
+	    state->enum_properties = TRUE;
+	    goto enumerate;
+	  case -1:
+	    return FALSE;
+	}
+      } else if ( getLocale(locale, &state->l) )
+      { switch( get_prop_def(property, ATOM_locale_property,
+			     lprop_list, &state->p) )
+	{ case 1:
+	    goto enumerate;
+	  case 0:
+	    state->p = lprop_list;
+	    state->enum_properties = TRUE;
+	    goto enumerate;
+	  case -1:
+	    return FALSE;
+	}
+      } else
+      { return FALSE;
+      }
+    }
+    case FRG_REDO:
+      state = CTX_PTR;
+      break;
+    case FRG_CUTTED:
+      state = CTX_PTR;
+      free_lstate(state);
+      succeed;
+    default:
+      assert(0);
+  }
+
+enumerate:
+  if ( !state->l )			/* first time, enumerating locales */
+  { Symbol s;
+
+    assert(state->e);
+    if ( (s=advanceTableEnum(state->e)) )
+    { state->l = s->value;
+    } else
+    { freeTableEnum(state->e);
+      assert(state != &statebuf);
+      return FALSE;
+    }
+  }
+
+  { term_t arg = PL_new_term_ref();
+
+    if ( !state->enum_properties )
+      _PL_get_arg(1, property, arg);
+
+    for(;;)
+    { if ( (*state->p->function)(state->l, arg PASS_LD) )
+      { if ( state->enum_properties )
+	{ if ( !PL_unify_term(property,
+			      PL_FUNCTOR, state->p->functor,
+			        PL_TERM, arg) )
+	    goto error;
+	}
+	if ( state->e )
+	{ if ( !unifyLocale(locale, state->l, TRUE) )
+	    goto error;
+	}
+
+	if ( advance_lstate(state) )
+	{ if ( state == &statebuf )
+	  { lprop_enum *copy = allocForeignState(sizeof(*copy));
+
+	    *copy = *state;
+	    state = copy;
+	  }
+
+	  ForeignRedoPtr(state);
+	}
+
+	if ( state != &statebuf )
+	  free_lstate(state);
+	return TRUE;
+      }
+
+      if ( !advance_lstate(state) )
+      { error:
+	if ( state != &statebuf )
+	  free_lstate(state);
+	return FALSE;
+      }
+    }
+  }
+}
+
+
+static int
+set_chars(term_t t, wchar_t **valp)
+{ wchar_t *s;
+
+  if ( PL_get_wchars(t, NULL, &s, CVT_ATOM|CVT_EXCEPTION) )
+  { free(*valp);
+    if ( (*valp = wcsdup(s)) )
+      return TRUE;
+    return PL_no_memory();
+  }
+
+  return FALSE;
+}
+
+
+#define MAX_GROUPING 10
+
+static int
+get_group_size_ex(term_t t, int *s)
+{ int i;
+
+  if ( PL_get_integer_ex(t, &i) )
+  { if ( i > 0 && i < CHAR_MAX )
+    { *s = i;
+      return TRUE;
+    }
+    return PL_domain_error("digit_group_size", t);
+  }
+
+  return FALSE;
+}
+
+
+static int
+set_grouping(term_t t, char **valp)
+{ GET_LD
+  char s[MAX_GROUPING];
+  term_t tail = PL_copy_term_ref(t);
+  term_t head = PL_new_term_ref();
+  char *o = s;
+
+  while(PL_get_list_ex(tail, head, tail))
+  { int g;
+
+    if ( o-s+2 >= MAX_GROUPING )
+      return PL_representation_error("digit_groups");
+
+    if ( PL_is_functor(head, FUNCTOR_repeat1) )
+    { if ( !PL_get_nil_ex(tail) )
+	return FALSE;
+
+      _PL_get_arg(1, head, head);
+      if ( get_group_size_ex(head, &g) )
+      { *o++ = g;
+	goto end;
+      }
+      return FALSE;
+    }
+    if ( get_group_size_ex(head, &g) )
+    { *o++ = g;
+    } else
+      return FALSE;
+  }
+
+  if ( PL_get_nil_ex(tail) )
+  { *o++ = CHAR_MAX;				/* no more grouping */
+  end:
+    *o++ = '\0';
+    free(*valp);
+    if ( (*valp = strdup(s)) )
+      return TRUE;
+    return PL_no_memory();
+  }
+
+  return FALSE;
+}
+
+
+/** locale_create(-Locale, +Default, +Options) is det.
+*/
+/// @memberof locale_create/3
+static
+PRED_IMPL("locale_create", 3, locale_create, 0)
+{ PRED_LD
+  PL_locale *def, *new;
+  char *lname;
+
+  if ( PL_get_chars(A2, &lname, CVT_LIST|CVT_STRING|REP_MB) )
+  { const char *old;
+
+    LOCK();
+    if ( (old=setlocale(LC_NUMERIC, lname)) )
+    { new = new_locale(NULL);
+      setlocale(LC_NUMERIC, old);
+    } else
+    { assert(0);				/* keep compiler happy */
+      return FALSE;
+    }
+    UNLOCK();
+    if ( !old )
+    { if ( errno == ENOENT )
+	return PL_existence_error("locale", A2);
+      else
+	return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setlocale");
+    }
+  } else
+  { if ( !getLocaleEx(A2, &def) )
+      return FALSE;
+    new = new_locale(def);
+    releaseLocale(def);
+  }
+
+  if ( new )
+  { atom_t alias = 0;
+    term_t tail = PL_copy_term_ref(A3);
+    term_t head = PL_new_term_ref();
+    term_t arg  = PL_new_term_ref();
+
+    while(PL_get_list_ex(tail, head, tail))
+    { atom_t pname;
+      int parity;
+
+      if ( !PL_get_name_arity(head, &pname, &parity) ||
+	   parity != 1 ||
+	   !PL_get_arg(1, head, arg) )
+      { PL_type_error("locale_property", head);
+	goto error;
+      }
+      if ( pname == ATOM_alias )
+      { if ( !PL_get_atom_ex(arg, &alias) )
+	  goto error;
+      } else if ( pname == ATOM_decimal_point )
+      { if ( !set_chars(arg, &new->decimal_point) )
+	  goto error;
+      } else if ( pname == ATOM_thousands_sep )
+      { if ( !set_chars(arg, &new->thousands_sep) )
+	  goto error;
+      } else if ( pname == ATOM_grouping )
+      { if ( !set_grouping(arg, &new->grouping) )
+	  goto error;
+      }
+    }
+    if ( !PL_get_nil_ex(tail) )
+    {
+    error:
+      free_locale(new);
+      return FALSE;
+    }
+
+    if ( alias && !alias_locale(new, alias) )
+      goto error;
+
+    return unifyLocale(A1, new, TRUE);
+  } else
+  { return PL_no_memory();
+  }
+}
+
+
+/** locale_destroy(+Locale) is det.
+*/
+/// @memberof locale_destroy/1
+static
+PRED_IMPL("locale_destroy", 1, locale_destroy, 0)
+{ PL_locale *l;
+
+  if ( getLocaleEx(A1, &l) )
+  { if ( l->alias )
+    { Symbol s;
+      atom_t alias = l->alias;
+
+      LOCK();
+      if ( (s=lookupHTable(GD->locale.localeTable, (void*)alias)) )
+	deleteSymbolHTable(GD->locale.localeTable, s);
+      l->alias = 0;
+      PL_unregister_atom(alias);
+      UNLOCK();
+    }
+
+    releaseLocale(l);
+    return TRUE;
+  }
+
+  return FALSE;
+}
+
+
+/** set_locale(+Locale) is det.
+*/
+/// @memberof set_locale/1
+static
+PRED_IMPL("set_locale", 1, set_locale, 0)
+{ PRED_LD
+  PL_locale *l = NULL;
+
+  if ( getLocaleEx(A1, &l) )
+  { PL_locale *ol = LD->locale.current;
+
+    if ( l != ol )
+    { IOSTREAM **sp;
+
+      LD->locale.current = l;		/* already acquired */
+      if ( ol )
+	releaseLocale(ol);
+
+      if ( (sp=_PL_streams()) )		/* set locale of standard streams */
+      { int i;
+
+	for(i=0; i<5; i++)
+	  Ssetlocale(sp[i], l, NULL);
+      }
+    }
+
+    return TRUE;
+  }
+
+  return FALSE;
+}
+
+
+/** current_locale(-Locale) is det.
+*/
+/// @memberof current_locale/1
+static
+PRED_IMPL("current_locale", 1, current_locale, 0)
+{ PRED_LD
+
+  if ( LD->locale.current )
+    return unifyLocale(A1, LD->locale.current, TRUE);
+
+  return FALSE;
+}
+
+
+
+		 /*******************************
+		 *	     C INTERFACE	*
+		 *******************************/
+
+
+static void
+initDefaultsStreamsLocale(PL_locale *l)
+{ IOSTREAM *s = S__getiob();
+  int i;
+
+  for(i=0; i<2; i++, s++)
+  { if ( !s->locale )
+      s->locale = acquireLocale(l);
+  }
+}
+
+
+void
+initLocale(void)
+{ GET_LD
+  PL_locale *def;
+
+  if ( !setlocale(LC_NUMERIC, "") )
+  { DEBUG(0, Sdprintf("Failed to set LC_NUMERIC locale\n"));
+  }
+
+  if ( (def = new_locale(NULL)) )
+  { alias_locale(def, ATOM_default);
+    def->references++;
+    GD->locale.default_locale = def;
+    LD->locale.current = acquireLocale(def);
+
+    initDefaultsStreamsLocale(def);
+  }
+}
+
+
+void
+updateLocale(int category, const char *locale)
+{ update_locale(GD->locale.default_locale, category, locale);
+}
+
+
+int
+initStreamLocale(IOSTREAM *s)
+{ GET_LD
+  PL_locale *l;
+
+  if ( LD )					/* a Prolog thread */
+    l = LD->locale.current;
+  else
+    l = GD->locale.default_locale;
+
+  if ( l )
+    s->locale = acquireLocale(l);
+
+  return TRUE;
+}
+
+
+PL_locale *
+acquireLocale(PL_locale *l)
+{ LOCK();
+  l->references++;
+  UNLOCK();
+
+  return l;
+}
+
+
+void
+releaseLocale(PL_locale *l)
+{ LOCK();
+  if ( --l->references == 0 && l->symbol == 0 && l->alias == 0 )
+    free_locale(l);
+  UNLOCK();
+}
+
+
+
+
+		 /*******************************
+		 *      PUBLISH PREDICATES	*
+		 *******************************/
+
+BeginPredDefs(locale)
+  PRED_DEF("locale_property", 2, locale_property, PL_FA_NONDETERMINISTIC)
+  PRED_DEF("locale_create",   3, locale_create,   0)
+  PRED_DEF("locale_destroy",  1, locale_destroy,  0)
+  PRED_DEF("set_locale",      1, set_locale,      0)
+  PRED_DEF("current_locale",  1, current_locale,  0)
+EndPredDefs
+
+#endif /*O_LOCALE*/
+
+/// @}

library/dialect/swi/os/pl-locale.h

@@ -0,0 +1,50 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2013, VU University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_LOCALE_H_INCLUDED
+#define PL_LOCALE_H_INCLUDED
+
+#define LOCALE_MAGIC 37838743
+
+typedef struct PL_locale
+{ atom_t	alias;		/* named alias (if any) */
+  atom_t	symbol;		/* blob handle */
+  int		magic;		/* LOCALE_MAGIC */
+  int		references;	/* Reference count */
+				/* POSIX locale properties */
+  wchar_t      *decimal_point;	/* Radix character */
+  wchar_t      *thousands_sep;	/* Separator for digit group left of radix character */
+  char	       *grouping;	/* Grouping  */
+} PL_locale;
+
+#define PL_HAVE_PL_LOCALE 1
+
+COMMON(void)		initLocale(void);
+COMMON(void)		updateLocale(int category, const char *locale);
+COMMON(PL_locale *)	acquireLocale(PL_locale *l);
+COMMON(void)		releaseLocale(PL_locale *l);
+COMMON(int)		initStreamLocale(IOSTREAM *s);
+COMMON(int)		unifyLocale(term_t t, PL_locale *l, int alias);
+COMMON(int)		getLocale(term_t t, PL_locale **lp);
+COMMON(int)		getLocaleEx(term_t t, PL_locale **lp);
+
+#endif /*PL_LOCALE_H_INCLUDED*/

library/dialect/swi/os/pl-option.c

@@ -0,0 +1,189 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2008, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Variable argument list:
+
+	atom_t	name
+	int	type	OPT_ATOM, OPT_STRING, OPT_BOOL, OPT_INT, OPT_LONG
+	pointer	value
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define MAXOPTIONS 32
+
+typedef union
+{ int *b;				/* boolean value */
+  long *l;				/* long value */
+  int  *i;				/* integer value */
+  uintptr_t *sz;			/* size_t value */
+  double *f;				/* double value */
+  char **s;				/* string value */
+  word *a;				/* atom value */
+  term_t *t;				/* term-reference */
+  void *ptr;				/* anonymous pointer */
+} optvalue;
+
+
+bool
+scan_options(term_t options, int flags, atom_t optype,
+	     const opt_spec *specs, ...)
+{ GET_LD
+  va_list args;
+  const opt_spec *s;
+  optvalue values[MAXOPTIONS];
+  term_t list = PL_copy_term_ref(options);
+  term_t head = PL_new_term_ref();
+  term_t tmp  = PL_new_term_ref();
+  term_t val  = PL_new_term_ref();
+  int n;
+
+  if ( truePrologFlag(PLFLAG_ISO) )
+    flags |= OPT_ALL;
+
+  va_start(args, specs);
+  for( n=0, s = specs; s->name; s++, n++ )
+    values[n].ptr = va_arg(args, void *);
+  va_end(args);
+
+  while ( PL_get_list(list, head, list) )
+  { atom_t name;
+    int arity;
+
+    if ( PL_get_name_arity(head, &name, &arity) )
+    { if ( name == ATOM_equals && arity == 2 )
+      { _PL_get_arg(1, head, tmp);
+
+	if ( !PL_get_atom(tmp, &name) )
+	  goto itemerror;
+	_PL_get_arg(2, head, val);
+      } else if ( arity == 1 )
+      { _PL_get_arg(1, head, val);
+      } else if ( arity == 0 )
+	PL_put_atom(val, ATOM_true);
+    } else if ( PL_is_variable(head) )
+    { return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
+    } else
+    { itemerror:
+      return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head);
+    }
+
+    for( n=0, s = specs; s->name; n++, s++ )
+    { if ( s->name == name )
+      { switch((s->type & OPT_TYPE_MASK))
+	{ case OPT_BOOL:
+	  { int bval;
+
+	    if ( !PL_get_bool_ex(val, &bval) )
+	      return FALSE;
+	    *values[n].b = bval;
+	    break;
+	  }
+	  case OPT_INT:
+	  { if ( !PL_get_integer_ex(val, values[n].i) )
+	      return FALSE;
+
+	    break;
+	  }
+	  case OPT_LONG:
+	  { if ( (s->type & OPT_INF) && PL_is_inf(val) )
+	      *values[n].l = LONG_MAX;
+	    else if ( !PL_get_long_ex(val, values[n].l) )
+	      return FALSE;
+
+	    break;
+	  }
+	  case OPT_NATLONG:
+	  { if ( !PL_get_long_ex(val, values[n].l) )
+	      return FALSE;
+	    if ( *(values[n].l) <= 0 )
+	      return PL_error(NULL, 0, NULL, ERR_DOMAIN,
+			      ATOM_not_less_than_one, val);
+
+	    break;
+	  }
+	  case OPT_SIZE:
+	  { if ( (s->type & OPT_INF) && PL_is_inf(val) )
+	      *values[n].sz = (size_t)-1;
+	    else if ( !PL_get_size_ex(val, values[n].sz) )
+	      return FALSE;
+
+	    break;
+	  }
+	  case OPT_DOUBLE:
+	  { if ( !PL_get_float_ex(val, values[n].f) )
+	      return FALSE;
+
+	    break;
+	  }
+	  case OPT_STRING:
+	  { char *str;
+
+	    if ( !PL_get_chars(val, &str, CVT_ALL|CVT_EXCEPTION) ) /* copy? */
+	      return FALSE;
+	    *values[n].s = str;
+	    break;
+	  }
+	  case OPT_ATOM:
+	  { atom_t a;
+
+	    if ( !PL_get_atom_ex(val, &a) )
+	      return FALSE;
+	    *values[n].a = a;
+	    break;
+	  }
+#ifdef O_LOCALE
+	  case OPT_LOCALE:
+	  { PL_locale *l;
+	    PL_locale **lp = values[n].ptr;
+
+	    if ( !getLocaleEx(val, &l) )
+	      return FALSE;
+	    *lp = l;
+	    break;
+	  }
+#endif
+	  case OPT_TERM:
+	  { *values[n].t = val;
+	    val = PL_new_term_ref();	/* can't reuse anymore */
+	    break;
+	  }
+	  default:
+	    assert(0);
+	    fail;
+	}
+	break;
+      }
+    }
+
+    if ( !s->name && (flags & OPT_ALL) )
+      goto itemerror;
+  }
+
+  if ( !PL_get_nil(list) )
+    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
+
+  succeed;
+}

library/dialect/swi/os/pl-option.h

@@ -0,0 +1,51 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2008, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef OPTION_H_INCLUDED
+#define OPTION_H_INCLUDED
+
+#define OPT_BOOL	(0)		/* types */
+#define OPT_INT		(1)
+#define OPT_STRING	(2)
+#define OPT_ATOM	(3)
+#define OPT_TERM	(4)		/* arbitrary term */
+#define OPT_LONG	(5)
+#define OPT_NATLONG	(6)		/* > 0 */
+#define OPT_SIZE	(7)		/* size_t */
+#define OPT_DOUBLE	(8)
+#define OPT_LOCALE	(9)
+#define OPT_TYPE_MASK	0xff
+#define OPT_INF		0x100		/* allow 'inf' */
+
+#define OPT_ALL		0x1		/* flags */
+
+typedef struct
+{ atom_t	name;			/* Name of option */
+  int		type;			/* Type of option */
+} opt_spec, *OptSpec;
+
+COMMON(bool)		scan_options(term_t list, int flags, atom_t name,
+				     const opt_spec *specs, ...);
+
+#endif /*OPTION_H_INCLUDED*/

library/dialect/swi/os/pl-os.h

@@ -0,0 +1,133 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+			      VU University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifdef HAVE_SYS_PARAM_H			/* get MAXPATHLEN */
+#include <sys/param.h>
+#endif
+
+
+		/********************************
+		*         MISCELLANEOUS         *
+		*********************************/
+
+extern char *OsError(void);
+extern bool initOs(void);
+
+
+		/********************************
+		*              FILES            *
+		*********************************/
+
+#ifndef STREAM_OPEN_BIN_READ
+#define STREAM_OPEN_BIN_READ "rb"
+#endif
+
+#ifndef STREAM_OPEN_BIN_WRITE
+#define STREAM_OPEN_BIN_WRITE "wb"
+#endif
+
+#ifdef HAVE_POPEN
+#define PIPE 1
+#define Popen(path, m)	Sopen_pipe(OsPath(path), m)
+#define Pclose(fd)	pclose(fd)
+#endif
+
+#ifndef MAXPATHLEN
+#ifdef PATH_MAX
+#define MAXPATHLEN PATH_MAX
+#else
+#ifdef PATHSIZE
+#define MAXPATHLEN PATHSIZE
+#endif
+#endif
+#endif
+
+COMMON(char*)	canoniseFileName(char *path);
+
+
+		/********************************
+		*        TIME CONVERSION        *
+		*********************************/
+
+typedef enum
+{ CPU_USER,
+  CPU_SYSTEM
+} cputime_kind;
+
+extern double	  CpuTime(cputime_kind);
+extern double	  WallTime(void);
+
+
+		 /*******************************
+		 *	      MEMORY		*
+		 *******************************/
+
+extern uintptr_t	UsedMemory(void);
+extern uintptr_t	FreeMemory(void);
+
+
+		/********************************
+		*       IOSTREAM DESCR. SETS	*
+		********************************/
+
+#if !defined(FD_ZERO) && !defined(__WINDOWS__)
+#ifdef HAVE_SYS_SELECT_H
+#include <sys/select.h>
+#else
+#define FD_ZERO(s)	{ *((uintptr_t *)(s)) = (0L); }
+#define FD_SET(fd, s)	{ *((uintptr_t *)(s)) |= ((uintptr_t)L << (fd)); }
+#define FD_ISSET(fd, s) ( (*((uintptr_t *)(s)) & ((uintptr_t)L << (fd))) != 0 )
+#endif
+#endif
+
+		/********************************
+		*        TERMINAL CONTROL       *
+		*********************************/
+
+#define TTY_COOKED	 1		/* Initial mode: echo */
+#define TTY_RAW		 2		/* Non-blocking, non-echo */
+#define TTY_OUTPUT	 3		/* enable post-processing */
+#define TTY_SAVE	 4		/* just save status */
+
+typedef struct
+{ void *state;				/* Saved state */
+  int   mode;				/* Prolog;'s view on mode */
+} ttybuf;
+
+extern ttybuf	ttytab;			/* saved tty status */
+extern int	ttymode;		/* Current tty mode */
+
+#define IsaTty(fd)	isatty(fd)
+
+extern bool PushTty(IOSTREAM *s, ttybuf *buf, int mode);
+extern bool PopTty(IOSTREAM *s, ttybuf *buf, int do_free);
+extern void ResetTty(void);
+
+
+		/********************************
+		*        PROCESS CONTROL        *
+		*********************************/
+
+extern int System(char *command);

library/dialect/swi/os/pl-privitf.c

@@ -0,0 +1,211 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 2008, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+#undef LD
+#define LD LOCAL_LD
+
+#ifdef __SWI_PROLOG__
+
+#define setHandle(h, w)		(*valTermRef(h) = (w))
+#define valHandleP(h)		valTermRef(h)
+
+#define valHandle(r) valHandle__LD(r PASS_LD)
+
+static inline word
+valHandle__LD(term_t r ARG_LD)
+{ Word p = valTermRef(r);
+
+  deRef(p);
+  return *p;
+}
+
+#endif
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This module defines extensions to pl-fli.c that are used internally, but
+not exported to the SWI-Prolog user. Most   of them are too specific for
+the public interface.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+		 /*******************************
+		 *     CHARACTER GET/UNIFY	*
+		 *******************************/
+
+/** PL_get_char(term_t c, int *p, int eof)
+
+Get a character code from a term and   store  in over p. Returns TRUE if
+successful. On failure it returns a  type   error.  If  eof is TRUE, the
+integer -1 or the atom end_of_file can used to specify and EOF character
+code.
+*/
+
+int
+PL_get_char(term_t c, int *p, int eof)
+{ GET_LD
+  int chr;
+  atom_t name;
+  PL_chars_t text;
+
+  if ( PL_get_integer(c, &chr) )
+  { if ( chr >= 0 )
+    { *p = chr;
+      return TRUE;
+    }
+    if ( eof && chr == -1 )
+    { *p = chr;
+      return TRUE;
+    }
+  } else if ( PL_get_text(c, &text, CVT_ATOM|CVT_STRING|CVT_LIST) &&
+	      text.length == 1 )
+  { *p = text.encoding == ENC_ISO_LATIN_1 ? text.text.t[0]&0xff
+					  : text.text.w[0];
+    return TRUE;
+  } else if ( eof && PL_get_atom(c, &name) && name == ATOM_end_of_file )
+  { *p = -1;
+    return TRUE;
+  }
+
+  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, c);
+}
+
+
+/** PL_unify_char(term_t chr, int c, int how)
+
+Unify a character.  Try to be as flexible as possible, only binding a
+variable `chr' to a code or one-char-atom.  E.g., this succeeds:
+
+    PL_unify_char('a', 97, PL_CODE)
+*/
+
+int
+PL_unify_char(term_t chr, int c, int how)
+{ GET_LD
+  int c2 = -1;
+
+  if ( PL_is_variable(chr) )
+  { switch(how)
+    { case PL_CHAR:
+      { atom_t a = (c == -1 ? ATOM_end_of_file : codeToAtom(c));
+
+	return PL_unify_atom(chr, a);
+      }
+      case PL_CODE:
+      case PL_BYTE:
+      default:
+	return PL_unify_integer(chr, c);
+    }
+  } else if ( PL_get_char(chr, &c2, TRUE) )
+    return c == c2;
+
+  return FALSE;
+}
+
+
+		 /*******************************
+		 *	  LIST BUILDING		*
+		 *******************************/
+
+#if __YAP_PROLOG__
+
+int
+allocList(size_t maxcells, list_ctx *ctx)
+{
+  CACHE_REGS
+  ctx->gstore = ctx->start = OpenList(maxcells PASS_REGS);
+  return (ctx->gstore != 0L);
+}
+
+int
+unifyList(term_t term, list_ctx *ctx)
+{
+  CACHE_REGS
+  if (!CloseList(ctx->gstore, TermNil))
+    return FALSE;
+  return Yap_unify(Yap_GetFromSlot(term), ctx->start);
+}
+
+int
+unifyDiffList(term_t head, term_t tail, list_ctx *ctx)
+{
+  CACHE_REGS
+  if (!CloseList(ctx->gstore, Yap_GetFromSlot(tail)))
+    return FALSE;
+  return Yap_unify(Yap_GetFromSlot(head), ctx->start);
+}
+
+#else
+
+int
+allocList(size_t maxcells, list_ctx *ctx)
+{ GET_LD
+  ctx->lp = ctx->gstore = allocGlobal(1+maxcells*3);
+
+  return TRUE;
+}
+
+int
+unifyList(term_t term, list_ctx *ctx)
+{ GET_LD
+  Word a;
+
+  ctx->gstore[0] = ATOM_nil;
+  gTop = &ctx->gstore[1];
+
+  a = valTermRef(term);
+  deRef(a);
+  if ( !unify_ptrs(a, ctx->lp, 0 PASS_LD) )
+  { gTop = ctx->lp;
+    return FALSE;
+  }
+
+  return TRUE;
+}
+
+int
+unifyDiffList(term_t head, term_t tail, list_ctx *ctx)
+{ GET_LD
+  Word a;
+
+  setVar(ctx->gstore[0]);
+  gTop = &ctx->gstore[1];
+
+  a = valTermRef(head);
+  deRef(a);
+  if ( !unify_ptrs(a, ctx->lp, 0 PASS_LD) )
+  { gTop = ctx->lp;
+    return FALSE;
+  }
+  a = valTermRef(tail);
+  deRef(a);
+  if ( !unify_ptrs(a, ctx->gstore, 0 PASS_LD) )
+  { gTop = ctx->lp;
+    return FALSE;
+  }
+
+  return TRUE;
+}
+
+#endif

library/dialect/swi/os/pl-privitf.h

@@ -0,0 +1,93 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2008, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#ifndef PL_PRIVITF_H_INCLUDED
+#define PL_PRIVITF_H_INCLUDED
+
+COMMON(int) 	PL_get_char(term_t c, int *p, int eof);
+COMMON(int) 	PL_unify_char(term_t chr, int c, int mode);
+COMMON(int)	PL_unify_predicate(term_t head, predicate_t pred, int how);
+
+
+
+		 /*******************************
+		 *	    LIST BUILDING	*
+		 *******************************/
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Quickly create a list on the stack. This   is for creating lists were we
+can give an upperbound to the length  in advance. By allocation upfront,
+we know there are no garbage  collections   or  stack-shifts  and we can
+avoid using term-references to address the list.
+
+    * allocList(size_t maxcells, list_ctx *ctx)
+    Allocate enough space on the stack for a list of maxcells elements.
+    The final list may be shorter!
+
+    * addSmallIntList(list_ctx *ctx, int value)
+    Add a small integer to the list
+
+    * unifyList(term_t term, list_ctx *ctx);
+    Unify term with the created list.  This closes the list and adjusts
+    the top of the stack.
+
+    * unifyDiffList(term_t head, term_t tail, list_ctx *ctx);
+    Represent the list as Head\Tail.  This adjusts the top of the stack.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#if __YAP_PROLOG__
+
+typedef struct list_ctx
+{
+  Term gstore;
+  Term start;
+} list_ctx;
+
+static inline void
+addSmallIntList(list_ctx *ctx, int value)
+{
+  ctx->gstore = ExtendList(ctx->gstore,MkIntTerm(value));
+}
+
+#else
+
+typedef struct list_ctx
+{ Word lp;
+  Word gstore;
+} list_ctx;
+
+static inline void
+addSmallIntList(list_ctx *ctx, int value)
+{ ctx->gstore[0] = consPtr(&ctx->gstore[1], TAG_COMPOUND|STG_GLOBAL);
+  ctx->gstore[1] = FUNCTOR_dot2;
+  ctx->gstore[2] = consInt(value);
+  ctx->gstore += 3;
+}
+#endif
+
+COMMON(int)	allocList(size_t maxcells, list_ctx *ctx);
+COMMON(int)	unifyList(term_t term, list_ctx *ctx);
+COMMON(int)	unifyDiffList(term_t head, term_t tail, list_ctx *ctx);
+
+#endif /*PL_PRIVITF_H_INCLUDED*/

library/dialect/swi/os/pl-rl.c

@@ -0,0 +1,635 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This module binds the  SWI-Prolog  terminal   I/O  to  the  GNU readline
+library. Existence of this  this  library   is  detected  by  configure.
+Binding is achieved by rebinding the read function of the Sinput stream.
+
+This  module  only  depends  on  the  public  interface  as  defined  by
+SWI-Prolog.h and SWI-Stream.h
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+#ifndef __WINDOWS__
+#include "pl-incl.h"
+#endif
+#include <string.h>
+#include <stdlib.h>
+#include "SWI-Stream.h"
+#include "SWI-Prolog.h"
+
+#ifdef __WINDOWS__
+#ifndef __YAP_PROLOG__
+#ifdef WIN64
+#include "config/win64.h"
+#else
+#include "config/win32.h"
+#endif
+#endif
+#else
+#include <config.h>
+#endif
+
+#if defined(__CYGWIN__) && defined(__YAP_PROLOG__)
+#include <sys/time.h>
+#endif
+
+
+/* Disabled if dmalloc() is used because the readline library is full of
+   leaks and freeing the line returned by readline is considered an
+   error by the dmalloc library
+*/
+
+#if defined(HAVE_LIBREADLINE) && defined(HAVE_READLINE_READLINE_H) && !defined(DMALLOC)
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_UXNT_H
+#include <uxnt.h>
+#endif
+#ifdef HAVE_CLOCK
+#include <time.h>
+#endif
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+#ifdef __WINDOWS__
+#include <io.h>
+#endif
+#ifdef O_RLC
+#include "win32/console/console.h"
+#endif
+
+#ifdef HAVE_RL_INSERT_CLOSE
+#define PAREN_MATCHING 1
+#endif
+
+#undef ESC				/* will be redefined ... */
+#ifdef META
+#undef META /* conflict with macports readline */
+#endif
+#include <stdio.h>			/* readline needs it */
+#include <errno.h>
+#define savestring(x)			/* avoid definition there */
+#include <readline/readline.h>
+extern int rl_done;			/* should be in readline.h, but */
+					/* isn't in some versions ... */
+#ifdef HAVE_READLINE_HISTORY_H
+#include <readline/history.h>
+#endif
+					/* missing prototypes in older */
+					/* readline.h versions */
+
+#ifndef RL_STATE_INITIALIZED
+int rl_readline_state = 0;
+#define RL_STATE_INITIALIZED 0
+#endif
+#ifndef HAVE_RL_SET_PROMPT
+#define rl_set_prompt(x) (void)0
+#endif
+#ifndef RL_CLEAR_PENDING_INPUT
+#define rl_clear_pending_input() (void)0
+#endif
+#ifndef RL_CLEANUP_AFTER_SIGNAL
+#define rl_cleanup_after_signal() (void)0
+#endif
+
+#if !defined(HAVE_RL_DONE) && defined(HAVE_DECL_RL_DONE) && !HAVE_DECL_RL_DONE
+/* surely not provided, so we provide a dummy.  We do this as
+   a global symbol, so if there is one in a dynamic library it
+   will work anyway.
+*/
+int rl_done;
+#endif
+
+
+static foreign_t
+pl_rl_read_init_file(term_t file)
+{ char *f;
+
+  if ( PL_get_file_name(file, &f, 0) )
+  {
+#ifdef O_XOS
+    char buf[MAXPATHLEN];
+    rl_read_init_file(_xos_os_filename(f, buf));
+#else
+    rl_read_init_file(f);
+#endif
+
+    PL_succeed;
+  }
+
+  PL_fail;
+}
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This is not really clear using   wide-character  handling. We now assume
+that the readline library can only do   wide characters using UTF-8. Not
+sure this is true, but is certainly covers most installations.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+static foreign_t
+pl_rl_add_history(term_t text)
+{ GET_LD
+  atom_t a;
+  static atom_t last = 0;
+
+  if ( PL_get_atom_ex(text, &a) )
+  { char *txt;
+
+    if ( a != last )
+    { if ( last )
+	PL_unregister_atom(last);
+      last = a;
+      PL_register_atom(last);
+
+      if ( PL_get_chars(text, &txt, CVT_ATOM|REP_MB|CVT_EXCEPTION) )
+	add_history(txt);
+      else
+	return FALSE;
+    }
+
+    return TRUE;
+  }
+
+  return FALSE;
+}
+
+
+static foreign_t
+pl_rl_write_history(term_t fn)
+{ char *s;
+  int rc;
+
+  if ( !PL_get_file_name(fn, &s, 0) )
+    return FALSE;
+
+  if ( (rc=write_history(s)) == 0 )
+    return TRUE;
+
+  errno = rc;
+  return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
+		  ATOM_write, ATOM_file, fn);
+}
+
+
+
+static foreign_t
+pl_rl_read_history(term_t fn)
+{ char *s;
+  int rc;
+
+  if ( !PL_get_file_name(fn, &s, 0) )
+    return FALSE;
+
+  if ( (rc=read_history(s)) == 0 )
+    return TRUE;
+
+  errno = rc;
+  return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
+		  ATOM_read, ATOM_file, fn);
+}
+
+
+
+static char *my_prompt    = NULL;
+static int   in_readline  = 0;
+static int   sig_at_level = -1;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Signal handling wrapper.
+
+This is tricky. The GNU readline   library places signal handlers around
+the   below   given   signals.   They    re-send   all   signals   using
+kill(getpid(),sig). This goes wrong in our  multi-threaded context as it
+will send signals meant for a thread (using pthread_kill()) to the wrong
+thread. The library time.pl from the  clib   package  was victim of this
+behaviour.
+
+We disable readline's signal handling  using   rl_catch_signals  = 0 and
+redo the work ourselves, where we call   the handler directly instead of
+re-sending the signal. See  "info  readline"   for  details  on readline
+signal handling issues.
+
+One of the problems is that the signal   handler may not return after ^C
+<abort>. Earlier versions uses PL_abort_handler()   to reset the basics,
+but  since  the  introduction  of  multi-threading  and  exception-based
+aborts, this no longer works. We set sig_at_level to the current nesting
+level if we receive a signal. If this is still the current nesting level
+if we reach readling again we assumed we broke out of the old invocation
+in a non-convential manner.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+typedef struct
+{ int			signo;		/* number of the signal */
+  struct sigaction	old_state;	/* old state for the signal */
+} sigstate;
+
+static void rl_sighandler(int sig);
+
+static sigstate signals[] =
+{ { SIGINT },
+#ifdef SIGTSTP
+  { SIGTSTP },
+  { SIGTTOU },
+  { SIGTTIN },
+#endif
+  { SIGALRM },
+  { SIGTERM },
+  { SIGQUIT },
+  { -1 },
+};
+
+
+static void
+prepare_signals(void)
+{ sigstate *s;
+
+  for(s=signals; s->signo != -1; s++)
+  { struct sigaction new;
+
+    memset(&new, 0, sizeof(new));
+    new.sa_handler = rl_sighandler;
+    sigaction(s->signo, &new, &s->old_state);
+  }
+}
+
+
+static void
+restore_signals(void)
+{ sigstate *s;
+
+  for(s=signals; s->signo != -1; s++)
+  { sigaction(s->signo, &s->old_state, NULL);
+  }
+}
+
+
+static void
+rl_sighandler(int sig)
+{ sigstate *s;
+
+  DEBUG(3, Sdprintf("Signal %d in readline\n", sig));
+
+  sig_at_level = in_readline;
+
+  if ( sig == SIGINT )
+    rl_free_line_state ();
+  rl_cleanup_after_signal ();
+  restore_signals();
+  Sreset();
+
+  for(s=signals; s->signo != -1; s++)
+  { if ( s->signo == sig )
+    { void (*func)(int) = s->old_state.sa_handler;
+
+      if ( func == SIG_DFL )
+      { unblockSignal(sig);
+	DEBUG(3, Sdprintf("Re-sending signal\n"));
+	raise(sig);			/* was: kill(getpid(), sig); */
+      } else if ( func != SIG_IGN )
+      { (*func)(sig);
+      }
+
+      break;
+    }
+  }
+
+  DEBUG(3, Sdprintf("Resetting after signal\n"));
+  prepare_signals();
+#ifdef HAVE_RL_RESET_AFTER_SIGNAL
+  rl_reset_after_signal ();
+#endif
+}
+
+
+static char *
+pl_readline(const char *prompt)
+{ char *line;
+
+  prepare_signals();
+  line = readline(prompt);
+  restore_signals();
+
+  return line;
+}
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+The GNU-readline library is not reentrant (or does not appear to be so).
+Therefore we will detect this and simply   call  the default function if
+reentrant access is tried.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#ifdef HAVE_RL_EVENT_HOOK
+static int
+input_on_fd(int fd)
+{ fd_set rfds;
+  struct timeval tv;
+
+  FD_ZERO(&rfds);
+  FD_SET(fd, &rfds);
+  tv.tv_sec = 0;
+  tv.tv_usec = 0;
+
+  return select(fd+1, &rfds, NULL, NULL, &tv) != 0;
+}
+
+static int
+event_hook(void)
+{ if ( Sinput->position )
+  { int64_t c0 = Sinput->position->charno;
+
+    while( !input_on_fd(0) )
+    { PL_dispatch(0, PL_DISPATCH_NOWAIT);
+      if ( Sinput->position->charno != c0 )
+      { if ( my_prompt )
+	  rl_set_prompt(my_prompt);
+	rl_forced_update_display();
+	c0 = Sinput->position->charno;
+	rl_done = FALSE;
+      }
+    }
+  } else
+    PL_dispatch(0, PL_DISPATCH_WAIT);
+
+  return TRUE;
+}
+#endif
+
+
+static void
+reset_readline(void)
+{ if ( in_readline )
+  { restore_signals();
+  }
+
+  if ( my_prompt )
+    remove_string(my_prompt);
+  my_prompt = NULL;
+  in_readline = 0;
+}
+
+
+static ssize_t
+Sread_readline(void *handle, char *buf, size_t size)
+{ GET_LD
+  intptr_t h = (intptr_t)handle;
+  int fd = (int) h;
+  int ttymode = PL_ttymode(Suser_input); /* Not so nice */
+  int rval;
+  PL_write_prompt(ttymode == PL_NOTTY);
+
+  switch( ttymode )
+  { case PL_RAWTTY:			/* get_single_char/1 */
+#ifdef O_RLC
+    { int chr = getkey();
+
+      if ( chr == 04 || chr == 26 )
+	return 0;			/* EOF */
+
+      buf[0] = chr & 0xff;
+      return 1;
+    }
+#endif
+    case PL_NOTTY:			/* -tty */
+#ifdef RL_NO_REENTRANT
+    notty:
+#endif
+    { PL_dispatch(fd, PL_DISPATCH_WAIT);
+      rval = read(fd, buf, size);
+      if ( rval > 0 && buf[rval-1] == '\n' )
+	PL_prompt_next(fd);
+
+      break;
+    }
+    case PL_COOKEDTTY:
+    default:
+    { char *line;
+      const char *prompt;
+
+#ifdef RL_NO_REENTRANT
+      if ( in_readline )
+      { Sprintf("[readline disabled] ");
+	PL_write_prompt(TRUE);
+	goto notty;			/* avoid reentrance */
+      }
+#endif
+
+#if HAVE_DECL_RL_EVENT_HOOK_
+      if ( !PL_dispatch(0, PL_DISPATCH_INSTALLED) ) {
+	rl_event_hook = NULL;
+      }
+#endif
+
+      prompt = PL_prompt_string(fd);
+      if ( prompt )
+	PL_add_to_protocol(prompt, strlen(prompt));
+
+      { char *oldp = my_prompt;
+
+	my_prompt = prompt ? store_string(prompt) : (char *)NULL;
+
+	if ( sig_at_level == in_readline )
+	{ sig_at_level = -1;
+	  reset_readline();
+	}
+
+#if __YAP_PROLOG__
+	rl_outstream = stderr;
+#endif
+	if ( in_readline++ )
+	{ int state = rl_readline_state;
+
+	  rl_clear_pending_input();
+#ifdef HAVE_RL_DISCARD_ARGUMENT
+	  rl_discard_argument();
+#endif
+	  rl_deprep_terminal();
+	  rl_readline_state = (RL_STATE_INITIALIZED);
+	  line = pl_readline(prompt);
+	  rl_prep_terminal(FALSE);
+	  rl_readline_state = state;
+	  rl_done = 0;
+	} else
+	  line = pl_readline(prompt);
+	in_readline--;
+
+	if ( my_prompt )
+	  remove_string(my_prompt);
+	my_prompt = oldp;
+      }
+
+      if ( line )
+      { size_t l = strlen(line);
+
+	if ( l >= size )
+	{ PL_warning("Input line too long");	/* must be tested! */
+	  l = size-1;
+	}
+	memcpy(buf, line, l);
+	buf[l++] = '\n';
+	rval = l;
+
+	/*Sdprintf("Read: '%s'\n", line);*/
+	free(line);
+      } else
+	rval = 0;
+    }
+  }
+
+  return rval;
+}
+
+
+static int
+prolog_complete(int ignore, int key)
+{ if ( rl_point > 0 && rl_line_buffer[rl_point-1] != ' ' )
+  {
+#if HAVE_DECL_RL_CATCH_SIGNALS_	/* actually version >= 1.2, or true readline */
+	rl_begin_undo_group();
+    rl_complete(ignore, key);
+    if ( rl_point > 0 && rl_line_buffer[rl_point-1] == ' ' )
+    {
+      rl_delete_text(rl_point-1, rl_point);
+      rl_point -= 1;
+      rl_delete(-1, key);
+    }
+    rl_end_undo_group();
+#endif
+  } else
+    rl_complete(ignore, key);
+
+  return 0;
+}
+
+
+static char *
+atom_generator(const char *prefix, int state)
+{ char *s = PL_atom_generator(prefix, state);
+
+  if ( s )
+  { char *copy = malloc(1 + strlen(s));
+
+    if ( copy )				/* else pretend no completion */
+      strcpy(copy, s);
+    s = copy;
+  }
+
+  return s;
+}
+
+
+static char **
+prolog_completion(const char *text, int start, int end)
+{ char **matches = NULL;
+
+  if ( (start == 1 && rl_line_buffer[0] == '[') ||	/* [file */
+       (start == 2 && strncmp(rl_line_buffer, "['", 2)) )
+    matches = rl_completion_matches((char *)text,	/* for pre-4.2 */
+				    rl_filename_completion_function);
+  else
+    matches = rl_completion_matches((char *)text,
+				    atom_generator);
+
+  return matches;
+}
+
+#undef read				/* UXNT redefinition */
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+For some obscure reasons,  notably  libreadline   6  can  show  very bad
+interactive behaviour. There is a timeout set   to  100000 (0.1 sec). It
+isn't particularly clear what this timeout is doing. I _think_ it should
+be synchronized PL_dispatch_hook(),  and  set  to   0  if  this  hook is
+non-null.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+install_t
+PL_install_readline(void)
+{ GET_LD
+  access_level_t alevel;
+
+#ifndef __WINDOWS__
+  if ( !truePrologFlag(PLFLAG_TTY_CONTROL) || !isatty(0) )
+    return;
+  // don't allow YAP to run readline under an Eclipse Console
+  if (getenv("EclipseVersion"))
+	return;
+#endif
+
+  alevel = setAccessLevel(ACCESS_LEVEL_SYSTEM);
+#if HAVE_DECL_RL_CATCH_SIGNALS_
+  rl_catch_signals = 0;
+#endif
+  rl_readline_name = "Prolog";
+  rl_attempted_completion_function = prolog_completion;
+#ifdef __WINDOWS__
+  rl_basic_word_break_characters = "\t\n\"\\'`@$><= [](){}+*!,|%&?";
+#else
+  rl_basic_word_break_characters = ":\t\n\"\\'`@$><= [](){}+*!,|%&?";
+#endif
+#ifdef HAVE_RL_COMPLETION_FUNC_T
+  rl_add_defun("prolog-complete", prolog_complete, '\t');
+#else
+  rl_add_defun("prolog-complete", (void *)prolog_complete, '\t');
+#endif
+#if HAVE_RL_INSERT_CLOSE
+  rl_add_defun("insert-close", rl_insert_close, ')');
+#endif
+#if HAVE_RL_SET_KEYBOARD_INPUT_TIMEOUT	/* see (*) */
+  rl_set_keyboard_input_timeout(20000);
+#endif
+
+  GD->os.rl_functions = *Sinput->functions;	/* structure copy */
+  GD->os.rl_functions.read = Sread_readline;	/* read through readline */
+
+  Sinput->functions  = &GD->os.rl_functions;
+  Soutput->functions = &GD->os.rl_functions;
+  Serror->functions  = &GD->os.rl_functions;
+
+#define PRED(name, arity, func, attr) \
+	PL_register_foreign_in_module("system", name, arity, func, attr)
+
+  PRED("rl_read_init_file", 1, pl_rl_read_init_file, 0);
+  PRED("rl_add_history",    1, pl_rl_add_history,    PL_FA_NOTRACE);
+  PRED("rl_write_history",  1, pl_rl_write_history,  0);
+  PRED("rl_read_history",   1, pl_rl_read_history,   0);
+  PL_set_prolog_flag("readline",    PL_BOOL, TRUE);
+  PL_set_prolog_flag("tty_control", PL_BOOL, TRUE);
+  PL_license("gpl", "GNU Readline library");
+  setAccessLevel(alevel);
+}
+
+#else /*HAVE_LIBREADLINE*/
+
+install_t
+PL_install_readline(void)
+{
+}
+
+#endif /*HAVE_LIBREADLINE*/

library/dialect/swi/os/pl-string.c

@@ -0,0 +1,254 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+#include "pl-string.h"
+#include "pl-ctype.h"
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+String operations that are needed for the shared IO library.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+		 /*******************************
+		 *	     ALLOCATION		*
+		 *******************************/
+
+char *
+store_string(const char *s)
+{ if ( s )
+  { char *copy = (char *)allocHeapOrHalt(strlen(s)+1);
+
+    strcpy(copy, s);
+    return copy;
+  } else
+  { return NULL;
+  }
+}
+
+
+void
+remove_string(char *s)
+{ if ( s )
+    freeHeap(s, strlen(s)+1);
+}
+
+		 /*******************************
+		 *	     NUMBERS		*
+		 *******************************/
+
+/*  Return the character representing some digit.
+
+ ** Fri Jun 10 10:45:40 1988  jan@swivax.UUCP (Jan Wielemaker)  */
+
+char
+digitName(int n, int smll)
+{ if (n <= 9)
+    return n + '0';
+  return n + (smll ? 'a' : 'A') - 10;
+}
+
+
+/*  Return the value of a digit when transforming a number of base 'b'.
+    Return '-1' if it is an illegal digit.
+
+ ** Fri Jun 10 10:46:40 1988  jan@swivax.UUCP (Jan Wielemaker)  */
+
+int
+digitValue(int b, int c)
+{ int v;
+
+  if ( b == 0 )
+    return c;				/* 0'c */
+  if ( b == 1 )
+    return -1;
+  if ( b <= 10 )
+  { v = c - '0';
+    if ( v < b )
+      return v;
+    return -1;
+  }
+  if ( c <= '9' )
+    return c - '0';
+  if (isUpper(c))
+    c = toLower(c);
+  c = c - 'a' + 10;
+  if ( c < b && c >= 10 )
+    return c;
+  return -1;
+}
+
+
+		/********************************
+		*  LESS COMMON BASIC FUNCTIONS  *
+		*********************************/
+
+
+bool
+strprefix(const char *string, const char *prefix)
+{ while(*prefix && *string == *prefix)
+    prefix++, string++;
+  if (*prefix == EOS )
+    succeed;
+  fail;
+}
+
+
+bool
+strpostfix(const char *string, const char *postfix)
+{ intptr_t offset = strlen(string) - strlen(postfix);
+
+  if ( offset < 0 )
+    fail;
+
+  return streq(&string[offset], postfix);
+}
+
+
+#ifndef HAVE_STRCASECMP
+int
+strcasecmp(const char *s1, const char *s2)
+{
+#ifdef HAVE_STRICMP
+  return stricmp(s1, s2);
+#else
+  while(*s1 && makeLower(*s1) == makeLower(*s2))
+    s1++, s2++;
+
+  return makeLower(*s1) - makeLower(*s2);
+#endif
+}
+#endif
+
+
+#ifndef HAVE_STRLWR
+char *
+strlwr(char *s)
+{ char *q;
+
+  for(q=s; *q; q++)
+    *q = makeLower(*q);
+
+  return s;
+}
+#endif
+
+
+bool
+stripostfix(const char *s, const char *e)
+{ size_t ls = strlen(s);
+  size_t le = strlen(e);
+
+  if ( ls >= le )
+    return strcasecmp(&s[ls-le], e) == 0;
+
+  return FALSE;
+}
+
+
+		 /*******************************
+		 *	MULTIBYTE STRINGS	*
+		 *******************************/
+
+typedef struct
+{ wchar_t *wcp;
+  int	   len;
+  int	   malloced;
+} wbuf;
+
+
+#if !defined(HAVE_MBSCOLL) || !defined(HAVE_MBCASESCOLL)
+static void
+wstolower(wchar_t *w, size_t len)
+{ wchar_t *e = &w[len];
+
+  for( ; w<e; w++ )
+    *w = towlower(*w);
+}
+
+static int
+int_mbscoll(const char *s1, const char *s2, int icase)
+{ size_t l1 = strlen(s1);
+  size_t l2 = strlen(s2);
+  wchar_t *w1;
+  wchar_t *w2;
+  int ml1, ml2;
+  mbstate_t mbs;
+  int rc;
+
+#if HAVE_ALLOCA
+  if ( l1 < 1024 && (w1 = alloca(sizeof(wchar_t)*(l1+1))) )
+  { ml1 = FALSE;
+  } else
+#endif
+  { w1 = PL_malloc_atomic(sizeof(wchar_t)*(l1+1));
+    ml1 = TRUE;
+  }
+#if HAVE_ALLOCA
+  if ( l2 < 1024 && (w2 = alloca(sizeof(wchar_t)*(l2+1))) )
+  { ml2 = FALSE;
+  } else
+#endif
+  { w2 = PL_malloc_atomic(sizeof(wchar_t)*(l2+1));
+    ml2 = TRUE;
+  }
+
+  memset(&mbs, 0, sizeof(mbs));
+  if ( mbsrtowcs(w1, &s1, l1+1, &mbs) == (size_t)-1 )
+  { rc = -2;
+    goto out;
+  }
+  if ( mbsrtowcs(w2, &s2, l2+1, &mbs) == (size_t)-1 )
+  { rc = 2;
+    goto out;
+  }
+  if ( icase )
+  { wstolower(w1, l1);
+    wstolower(w2, l2);
+  }
+
+  rc = wcscoll(w1, w2);
+
+out:
+  if ( ml1 ) PL_free(w1);
+  if ( ml2 ) PL_free(w2);
+
+  return rc;
+}
+#endif
+
+
+#ifndef HAVE_MBSCOLL
+int
+mbscoll(const char *s1, const char *s2)
+{ return int_mbscoll(s1, s2, FALSE);
+}
+#endif
+
+
+#ifndef HAVE_MBSCASECOLL
+int
+mbscasecoll(const char *s1, const char *s2)
+{ return int_mbscoll(s1, s2, TRUE);
+}
+#endif

library/dialect/swi/os/pl-string.h

@@ -0,0 +1,48 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2011, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_STRING_H_INCLUDED
+#define PL_STRING_H_INCLUDED
+
+COMMON(char *) 	store_string(const char *s);
+COMMON(void) 		remove_string(char *s);
+COMMON(char) 		digitName(int n, int smll);
+COMMON(int) 		digitValue(int b, int c);
+COMMON(bool) 		strprefix(const char *string, const char *prefix);
+COMMON(bool) 		strpostfix(const char *string, const char *postfix);
+COMMON(bool) 		stripostfix(const char *string, const char *postfix);
+#ifndef HAVE_STRCASECMP
+COMMON(int) 		strcasecmp(const char *s1, const char *s2);
+#endif
+#ifndef HAVE_STRLWR
+COMMON(char *) 		strlwr(char *s);
+#endif
+#ifndef HAVE_MBSCOLL
+COMMON(int)		mbscoll(const char *s1, const char *s2);
+#endif
+#ifndef HAVE_MBSCASECOLL
+COMMON(int)		mbscasecoll(const char *s1, const char *s2);
+#endif
+
+#endif /*PL_STRING_H_INCLUDED*/

library/dialect/swi/os/pl-table.c

@@ -0,0 +1,473 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2012, University of Amsterdam
+			      VU University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+/*#define O_DEBUG 1*/
+#include "pl-incl.h"
+#ifdef O_PLMT
+#define LOCK_TABLE(t)   if ( t->mutex ) simpleMutexLock(t->mutex)
+#define UNLOCK_TABLE(t)	if ( t->mutex ) simpleMutexUnlock(t->mutex)
+#else
+#define LOCK_TABLE(t) (void)0
+#define UNLOCK_TABLE(t) (void)0
+#endif
+
+static inline Symbol rawAdvanceTableEnum(TableEnum e);
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This file provides generic hash-tables. Most   of  the implementation is
+rather  straightforward.  Special  are  the  *TableEnum()  functions  to
+create, advance over and destroy enumerator   objects. These objects are
+used to enumerate the symbols of these   tables,  used primarily for the
+pl_current_* predicates.
+
+The enumerators cause  two  things:  (1)   as  long  as  enumerators are
+associated, the table will not  be  rehashed   and  (2)  if  symbols are
+deleted  that  are  referenced  by  an  enumerator,  the  enumerator  is
+automatically advanced to the next free  symbol. This, in general, makes
+the enumeration of hash-tables safe.
+
+TBD: Resizing hash-tables causes major  headaches for concurrent access.
+We can avoid this by using a dynamic array for the list of hash-entries.
+Ongoing work in  the  RDF  store   shows  hash-tables  that  can  handle
+concurrent lock-free access.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+static Symbol *
+allocHTableEntries(int buckets)
+{ size_t bytes = buckets * sizeof(Symbol);
+  Symbol *p;
+
+  p = allocHeapOrHalt(bytes);
+  memset(p, 0, bytes);
+
+  return p;
+}
+
+
+Table
+newHTable(int buckets)
+{ Table ht;
+
+  ht		  = allocHeapOrHalt(sizeof(struct table));
+  ht->buckets	  = (buckets & ~TABLE_MASK);
+  ht->size	  = 0;
+  ht->enumerators = NULL;
+  ht->free_symbol = NULL;
+  ht->copy_symbol = NULL;
+#ifdef O_PLMT
+  if ( (buckets & TABLE_UNLOCKED) )
+    ht->mutex = NULL;
+  else
+  { ht->mutex     = allocHeapOrHalt(sizeof(simpleMutex));
+    simpleMutexInit(ht->mutex);
+  }
+#endif
+
+  ht->entries = allocHTableEntries(ht->buckets);
+  return ht;
+}
+
+
+void
+destroyHTable(Table ht)
+{
+#ifdef O_PLMT
+  if ( ht->mutex )
+  { simpleMutexDelete(ht->mutex);
+    freeHeap(ht->mutex, sizeof(*ht->mutex));
+    ht->mutex = NULL;
+  }
+#endif
+
+  clearHTable(ht);
+  freeHeap(ht->entries, ht->buckets * sizeof(Symbol));
+  freeHeap(ht, sizeof(struct table));
+}
+
+
+#if O_DEBUG
+static int lookups;
+static int cmps;
+
+int
+exitTables(int status, void *arg)
+{ (void)status;
+  (void)arg;
+
+  Sdprintf("hashstat: Anonymous tables: %d lookups using %d compares\n",
+	   lookups, cmps);
+
+  return 0;
+}
+#endif
+
+
+void
+initTables(void)
+{ static int done = FALSE;
+
+  if ( !done )
+  { done = TRUE;
+
+    DEBUG(MSG_HASH_STAT, PL_on_halt(exitTables, NULL));
+  }
+}
+
+
+Symbol
+lookupHTable(Table ht, void *name)
+{ Symbol s = ht->entries[pointerHashValue(name, ht->buckets)];
+
+  DEBUG(MSG_HASH_STAT, lookups++);
+  for( ; s; s = s->next)
+  { DEBUG(MSG_HASH_STAT, cmps++);
+    if ( s->name == name )
+      return s;
+  }
+
+  return NULL;
+}
+
+#ifdef O_DEBUG
+void
+checkHTable(Table ht)
+{ int i;
+  int n = 0;
+
+  for(i=0; i<ht->buckets; i++)
+  { Symbol s;
+
+    for(s=ht->entries[i]; s; s=s->next)
+    { assert(lookupHTable(ht, s->name) == s);
+      n++;
+    }
+  }
+
+  assert(n == ht->size);
+}
+#endif
+
+/* MT: Locked by calling addHTable()
+*/
+
+static Symbol
+rehashHTable(Table ht, Symbol map)
+{ Symbol *newentries, *oldentries;
+  int     newbuckets, oldbuckets;
+  int     i;
+#if P_PLMT
+  int     safe_copy = (ht->mutex != NULL);
+#else
+  int     safe_copy = TRUE;
+#endif
+
+  newbuckets = ht->buckets*2;
+  newentries = allocHTableEntries(newbuckets);
+
+  DEBUG(MSG_HASH_STAT,
+	Sdprintf("Rehashing table %p to %d entries\n", ht, ht->buckets));
+
+  for(i=0; i<ht->buckets; i++)
+  { Symbol s, n;
+
+    if ( safe_copy )
+    { for(s=ht->entries[i]; s; s = n)
+      { int v = (int)pointerHashValue(s->name, newbuckets);
+	Symbol s2 = allocHeapOrHalt(sizeof(*s2));
+
+	n = s->next;
+	if ( s == map )
+	  map = s2;
+	*s2 = *s;
+	s2->next = newentries[v];
+	newentries[v] = s2;
+      }
+    } else
+    { for(s=ht->entries[i]; s; s = n)
+      { int v = (int)pointerHashValue(s->name, newbuckets);
+
+	n = s->next;
+	s->next = newentries[v];
+	newentries[v] = s;
+      }
+    }
+  }
+
+  oldentries  = ht->entries;
+  oldbuckets  = ht->buckets;
+  ht->entries = newentries;
+  ht->buckets = newbuckets;
+
+  if ( safe_copy )
+  {					/* Here we should be waiting until */
+					/* active lookup are finished */
+    for(i=0; i<oldbuckets; i++)
+    { Symbol s, n;
+
+      for(s=oldentries[i]; s; s = n)
+      { n = s->next;
+
+	s->next = NULL;			/* that causes old readers to stop */
+	freeHeap(s, sizeof(*s));
+      }
+    }
+  }
+
+  freeHeap(oldentries, oldbuckets * sizeof(Symbol));
+  DEBUG(CHK_SECURE, checkHTable(ht));
+
+  return map;
+}
+
+
+Symbol
+addHTable(Table ht, void *name, void *value)
+{ Symbol s;
+  int v;
+
+  LOCK_TABLE(ht);
+  v = (int)pointerHashValue(name, ht->buckets);
+  if ( lookupHTable(ht, name) )
+  { UNLOCK_TABLE(ht);
+    return NULL;
+  }
+  s = allocHeapOrHalt(sizeof(struct symbol));
+  s->name  = name;
+  s->value = value;
+  s->next  = ht->entries[v];
+  ht->entries[v] = s;
+  ht->size++;
+  DEBUG(9, Sdprintf("addHTable(0x%x, 0x%x, 0x%x) --> size = %d\n",
+		    ht, name, value, ht->size));
+
+  if ( ht->buckets * 2 < ht->size && !ht->enumerators )
+    s = rehashHTable(ht, s);
+  UNLOCK_TABLE(ht);
+
+  DEBUG(1, checkHTable(ht));
+  return s;
+}
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Note: s must be in the table!
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+void
+deleteSymbolHTable(Table ht, Symbol s)
+{ int v;
+  Symbol *h;
+  TableEnum e;
+
+  LOCK_TABLE(ht);
+  v = (int)pointerHashValue(s->name, ht->buckets);
+  h = &ht->entries[v];
+
+  for( e=ht->enumerators; e; e = e->next )
+  { if ( e->current == s )
+      rawAdvanceTableEnum(e);
+  }
+
+  for( ; *h; h = &(*h)->next )
+  { if ( *h == s )
+    { *h = (*h)->next;
+
+      s->next = NULL;				/* force crash */
+      s->name = NULL;
+      s->value = NULL;
+      freeHeap(s, sizeof(struct symbol));
+      ht->size--;
+
+      break;
+    }
+  }
+
+  UNLOCK_TABLE(ht);
+}
+
+
+void
+clearHTable(Table ht)
+{ int n;
+  TableEnum e;
+
+  LOCK_TABLE(ht);
+  for( e=ht->enumerators; e; e = e->next )
+  { e->current = NULL;
+    e->key     = ht->buckets;
+  }
+
+  for(n=0; n < ht->buckets; n++)
+  { Symbol s, q;
+
+    for(s = ht->entries[n]; s; s = q)
+    { q = s->next;
+
+      if ( ht->free_symbol )
+	(*ht->free_symbol)(s);
+
+      freeHeap(s, sizeof(struct symbol));
+    }
+
+    ht->entries[n] = NULL;
+  }
+
+  ht->size = 0;
+  UNLOCK_TABLE(ht);
+}
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Table copyHTable(Table org)
+    Make a copy of a hash-table.  This is used to realise the copy-on-write
+    as defined by SharedTable.  The table is copied to have exactly the
+    same dimensions as the original.  If the copy_symbol function is
+    provided, it is called to allow duplicating the symbols name or value
+    fields.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+Table
+copyHTable(Table org)
+{ Table ht;
+  int n;
+
+  ht = allocHeapOrHalt(sizeof(struct table));
+  LOCK_TABLE(org);
+  *ht = *org;				/* copy all attributes */
+#ifdef O_PLMT
+  ht->mutex = NULL;
+#endif
+  ht->entries = allocHTableEntries(ht->buckets);
+
+  for(n=0; n < ht->buckets; n++)
+  { Symbol s, *q;
+
+    q = &ht->entries[n];
+    for(s = org->entries[n]; s; s = s->next)
+    { Symbol s2 = allocHeapOrHalt(sizeof(*s2));
+
+      *q = s2;
+      q = &s2->next;
+      s2->name = s->name;
+      s2->value = s->value;
+
+      if ( ht->copy_symbol )
+	(*ht->copy_symbol)(s2);
+    }
+    *q = NULL;
+  }
+#ifdef O_PLMT
+  if ( org->mutex )
+  { ht->mutex = allocHeapOrHalt(sizeof(simpleMutex));
+    simpleMutexInit(ht->mutex);
+  }
+#endif
+  UNLOCK_TABLE(org);
+
+  return ht;
+}
+
+
+		 /*******************************
+		 *	    ENUMERATING		*
+		 *******************************/
+
+TableEnum
+newTableEnum(Table ht)
+{ TableEnum e = allocHeapOrHalt(sizeof(struct table_enum));
+  Symbol n;
+
+  LOCK_TABLE(ht);
+  e->table	  = ht;
+  e->key	  = 0;
+  e->next	  = ht->enumerators;
+  ht->enumerators = e;
+
+  n = ht->entries[0];
+  while(!n && ++e->key < ht->buckets)
+    n=ht->entries[e->key];
+  e->current = n;
+  UNLOCK_TABLE(ht);
+
+  return e;
+}
+
+
+void
+freeTableEnum(TableEnum e)
+{ TableEnum *ep;
+  Table ht;
+
+  if ( !e )
+    return;
+
+  ht = e->table;
+  LOCK_TABLE(ht);
+  for( ep=&ht->enumerators; *ep ; ep = &(*ep)->next )
+  { if ( *ep == e )
+    { *ep = (*ep)->next;
+
+      freeHeap(e, sizeof(*e));
+      break;
+    }
+  }
+  UNLOCK_TABLE(ht);
+}
+
+
+static inline Symbol
+rawAdvanceTableEnum(TableEnum e)
+{ Symbol s, n;
+  Table ht = e->table;
+
+  if ( !(s = e->current) )
+    return s;
+  n = s->next;
+
+  while(!n)
+  { if ( ++e->key >= ht->buckets )
+    { e->current = NULL;
+      return s;
+    }
+
+    n=ht->entries[e->key];
+  }
+  e->current = n;
+
+  return s;
+}
+
+
+Symbol
+advanceTableEnum(TableEnum e)
+{ Symbol s;
+#ifdef O_PLMT
+  Table ht = e->table;
+#endif
+
+  LOCK_TABLE(ht);
+  s = rawAdvanceTableEnum(e);
+  UNLOCK_TABLE(ht);
+
+  return s;
+}

library/dialect/swi/os/pl-table.h

@@ -0,0 +1,100 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2008, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef TABLE_H_INCLUDED
+#define TABLE_H_INCLUDED
+
+typedef struct table *		Table;		/* (numeric) hash table */
+typedef struct symbol *		Symbol;		/* symbol of hash table */
+typedef struct table_enum *	TableEnum;	/* Enumerate table entries */
+
+struct table
+{ int		buckets;	/* size of hash table */
+  int		size;		/* # symbols in the table */
+  TableEnum	enumerators;	/* Handles for enumeration */
+#ifdef O_PLMT
+  simpleMutex  *mutex;		/* Mutex to guard table */
+#endif
+  void		(*copy_symbol)(Symbol s);
+  void		(*free_symbol)(Symbol s);
+  Symbol	*entries;	/* array of hash symbols */
+};
+
+struct symbol
+{ Symbol	next;		/* next in chain */
+  void *	name;		/* name entry of symbol */
+  void *	value;		/* associated value with name */
+};
+
+struct table_enum
+{ Table		table;		/* Table we are working on */
+  int		key;		/* Index of current symbol-chain */
+  Symbol	current;	/* The current symbol */
+  TableEnum	next;		/* More choice points */
+};
+
+COMMON(void)		initTables(void);
+COMMON(Table)		newHTable(int size);
+COMMON(void)		destroyHTable(Table ht);
+COMMON(Symbol)		lookupHTable(Table ht, void *name);
+COMMON(Symbol)		addHTable(Table ht, void *name, void *value);
+COMMON(void)		deleteSymbolHTable(Table ht, Symbol s);
+COMMON(void)		clearHTable(Table ht);
+COMMON(Table)		copyHTable(Table org);
+COMMON(TableEnum)	newTableEnum(Table ht);
+COMMON(void)		freeTableEnum(TableEnum e);
+COMMON(Symbol)		advanceTableEnum(TableEnum e);
+
+#define TABLE_UNLOCKED		0x10000000L /* do not create mutex for table */
+#define TABLE_MASK		0xf0000000UL
+
+#define pointerHashValue(p, size) ((((intptr_t)(p) >> LMASK_BITS) ^ \
+				    ((intptr_t)(p) >> (LMASK_BITS+5)) ^ \
+				    ((intptr_t)(p))) & \
+				   ((size)-1))
+
+#define for_table(ht, s, code) \
+	{ int _k; \
+	  PL_LOCK(L_TABLE); \
+	  for(_k = 0; _k < (ht)->buckets; _k++) \
+	  { Symbol _n, s; \
+	    for(s=(ht)->entries[_k]; s; s = _n) \
+	    { _n = s->next; \
+	      code; \
+	    } \
+	  } \
+          PL_UNLOCK(L_TABLE); \
+	}
+#define for_unlocked_table(ht, s, code) \
+	{ int _k; \
+	  for(_k = 0; _k < (ht)->buckets; _k++) \
+	  { Symbol _n, s; \
+	    for(s=(ht)->entries[_k]; s; s = _n) \
+	    { _n = s->next; \
+	      code; \
+	    } \
+	  } \
+	}
+
+#endif /*TABLE_H_INCLUDED*/

library/dialect/swi/os/pl-text.h

@@ -0,0 +1,91 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker and Anjo Anjewierden
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_TEXT_H_INCLUDED
+#define PL_TEXT_H_INCLUDED
+
+typedef enum
+{ PL_CHARS_MALLOC,			/* malloced data */
+  PL_CHARS_RING,			/* stored in the buffer ring */
+  PL_CHARS_HEAP,			/* stored in program area (atoms) */
+  PL_CHARS_STACK,			/* stored on the global stack */
+  PL_CHARS_LOCAL			/* stored in in-line buffer */
+} PL_chars_alloc_t;
+
+
+typedef struct
+{ union
+  { char *t;				/* tranditional 8-bit char* */
+    pl_wchar_t *w;			/* wide character string */
+  } text;
+  size_t length;
+					/* private stuff */
+  IOENC encoding;			/* how it is encoded */
+  PL_chars_alloc_t storage;		/* how it is stored */
+  int canonical;			/* TRUE: ENC_ISO_LATIN_1 or ENC_WCHAR */
+  char buf[100];			/* buffer for simple stuff */
+} PL_chars_t;
+
+#define PL_init_text(txt) \
+	{ (txt)->text.t    = NULL; \
+	  (txt)->encoding  = ENC_UNKNOWN; \
+	  (txt)->storage   = PL_CHARS_LOCAL; \
+	  (txt)->canonical = FALSE; \
+	}
+
+int	PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type);
+int	PL_unify_text_range(term_t term, PL_chars_t *text,
+			    size_t from, size_t len, int type);
+
+int	PL_promote_text(PL_chars_t *text);
+int	PL_demote_text(PL_chars_t *text);
+int	PL_mb_text(PL_chars_t *text, int flags);
+int	PL_canonise_text(PL_chars_t *text);
+
+int	PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
+		    size_t len);
+int	PL_concat_text(int n, PL_chars_t **text, PL_chars_t *result);
+
+void	PL_free_text(PL_chars_t *text);
+void	PL_save_text(PL_chars_t *text, int flags);
+
+COMMON(int)		PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD);
+COMMON(Atom)		textToAtom(PL_chars_t *text);
+
+COMMON(IOSTREAM *)	Sopen_text(PL_chars_t *text, const char *mode);
+COMMON(void)		PL_text_recode(PL_chars_t *text, IOENC encoding);
+
+					/* pl-fli.c */
+COMMON(int)		get_atom_ptr_text(Atom atom, PL_chars_t *text);
+COMMON(int)		get_atom_text(atom_t atom, PL_chars_t *text);
+COMMON(int)		get_string_text(atom_t atom, PL_chars_t *text ARG_LD);
+
+static inline int
+text_get_char(const PL_chars_t *t, size_t i)
+{ assert(t->canonical);
+  return t->encoding == ENC_ISO_LATIN1 ? t->text.t[i]&0xff
+					: t->text.w[i];
+}
+
+#endif /*PL_TEXT_H_INCLUDED*/

library/dialect/swi/os/pl-thread.h

@@ -0,0 +1,156 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2012, University of Amsterdam
+			      VU University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef PL_THREAD_H_DEFINED
+#define PL_THREAD_H_DEFINED
+
+#ifdef THREADS
+#include <pthread.h>
+
+typedef pthread_mutex_t simpleMutex;
+
+#define simpleMutexInit(p)	pthread_mutex_init(p, NULL)
+#define simpleMutexDelete(p)	pthread_mutex_destroy(p)
+#define simpleMutexLock(p)	pthread_mutex_lock(p)
+#define simpleMutexUnlock(p)	pthread_mutex_unlock(p)
+
+typedef pthread_mutex_t recursiveMutex;
+
+#define NEED_RECURSIVE_MUTEX_INIT 1
+extern int recursiveMutexInit(recursiveMutex *m);
+#define recursiveMutexDelete(p)  pthread_mutex_destroy(p)
+#define recursiveMutexLock(p)    pthread_mutex_lock(p)
+#define recursiveMutexTryLock(p) pthread_mutex_trylock(p)
+#define recursiveMutexUnlock(p)  pthread_mutex_unlock(p)
+
+
+typedef struct counting_mutex
+{ simpleMutex mutex;                    /* mutex itself */
+  const char *name;                     /* name of the mutex */
+  long count;                           /* # times locked */
+  long unlocked;                        /* # times unlocked */
+#ifdef O_CONTENTION_STATISTICS
+  long collisions;                      /* # contentions */
+#endif
+  struct counting_mutex *next;          /* next of allocated chain */
+} counting_mutex;
+
+extern counting_mutex  *allocSimpleMutex(const char *name);
+extern void             freeSimpleMutex(counting_mutex *m);
+
+extern counting_mutex _PL_mutexes[];	/* Prolog mutexes */
+
+#define L_MISC          0
+#define L_ALLOC         1
+#define L_ATOM          2
+#define L_FLAG          3
+#define L_FUNCTOR       4
+#define L_RECORD        5
+#define L_THREAD        6
+#define L_PREDICATE     7
+#define L_MODULE        8
+#define L_TABLE         9
+#define L_BREAK        10
+#define L_FILE         11
+#define L_SEETELL      12
+#define L_PLFLAG       13
+#define L_OP           14
+#define L_INIT         15
+#define L_TERM         16
+#define L_GC           17
+#define L_AGC          18
+#define L_STOPTHEWORLD 19
+#define L_FOREIGN      20
+#define L_OS           21
+#define L_LOCALE       23
+#ifdef __WINDOWS__
+#define L_DDE	       24
+#define L_CSTACK       25
+#endif
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+The IF_MT(id, g) macro  is  used  to   bypass  mutexes  if  threading  is
+disabled. We cannot do this for the L_THREAD mutex however as we need to
+control when threads can be created.
+
+We  assume  id  ==  L_THREAD  is  optimized  away  if  id  is  known  at
+compile-time
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+#define IF_MT(id,g) g
+//#define IF_MT(id, g) if ( id == L_THREAD  ) g
+
+#ifdef O_CONTENTION_STATISTICS
+#define countingMutexLock(cm) \
+	do \
+	{ if ( pthread_mutex_trylock(&(cm)->mutex) == EBUSY ) \
+	  { (cm)->collisions++; \
+	    pthread_mutex_lock(&(cm)->mutex); \
+	  } \
+	  (cm)->count++; \
+	} while(0)
+#else
+#define countingMutexLock(cm) \
+	do \
+	{ simpleMutexLock(&(cm)->mutex); \
+	  (cm)->count++; \
+	} while(0)
+#endif
+#define countingMutexUnlock(cm) \
+	do \
+	{ (cm)->unlocked++; \
+	  assert((cm)->unlocked <= (cm)->count); \
+	  simpleMutexUnlock(&(cm)->mutex); \
+	} while(0)
+
+//#define O_DEBUG_MT
+#ifdef O_DEBUG_MT
+#define PL_LOCK(id) \
+	do { Sdprintf("[%d] %s:%d: LOCK(%s)\n", \
+		      pthread_self(),		     \
+		      __BASE_FILE__, __LINE__, #id); \
+             countingMutexLock(&_PL_mutexes[id]); \
+	   } while(0)
+#define PL_UNLOCK(id) \
+	do { Sdprintf("[%d] %s:%d: UNLOCK(%s)\n", \
+		      pthread_self(), \
+		      __BASE_FILE__, __LINE__, #id); \
+	     countingMutexUnlock(&_PL_mutexes[id]); \
+	   } while(0)
+#else
+#define PL_LOCK(id)   IF_MT(id, countingMutexLock(&_PL_mutexes[id]))
+#define PL_UNLOCK(id) IF_MT(id, countingMutexUnlock(&_PL_mutexes[id]))
+#endif
+#undef O_DEBUG_MT
+
+#define IOLOCK  recursiveMutex
+
+#else
+#define PL_LOCK(X)
+#define PL_UNLOCK(X)
+
+typedef void *		IOLOCK;
+#endif
+
+#endif
+
+

library/dialect/swi/os/pl-util.c

@@ -0,0 +1,69 @@
+
+#include "pl-incl.h"
+#include "pl-ctype.h"
+
+#ifndef HAVE_STRICMP
+int
+stricmp(const char *s1, const char *s2)
+{ while(*s1 && makeLower(*s1) == makeLower(*s2))
+    s1++, s2++;
+
+  return makeLower(*s1) - makeLower(*s2);
+}
+#endif
+
+#if !defined(HAVE_MBSCOLL) || !defined(HAVE_MBCASESCOLL)
+static void
+wstolower(wchar_t *w, size_t len)
+{ wchar_t *e = &w[len];
+
+  for( ; w<e; w++ )
+    *w = towlower(*w);
+}
+
+static int
+int_mbscoll(const char *s1, const char *s2, int icase)
+{ size_t l1 = strlen(s1);
+  size_t l2 = strlen(s2);
+  wchar_t *w1;
+  wchar_t *w2;
+  int ml1, ml2;
+  mbstate_t mbs;
+  int rc;
+
+  if ( l1 < 1024 && (w1 = alloca(sizeof(wchar_t)*(l1+1))) )
+  { ml1 = FALSE;
+  } else
+  { w1 = PL_malloc(sizeof(wchar_t)*(l1+1));
+    ml1 = TRUE;
+  }
+  if ( l2 < 1024 && (w2 = alloca(sizeof(wchar_t)*(l2+1))) )
+  { ml2 = FALSE;
+  } else
+  { w2 = PL_malloc(sizeof(wchar_t)*(l2+1));
+    ml2 = TRUE;
+  }
+
+  memset(&mbs, 0, sizeof(mbs));
+  if ( mbsrtowcs(w1, &s1, l1+1, &mbs) == (size_t)-1 )
+  { rc = -2;
+    goto out;
+  }
+  if ( mbsrtowcs(w2, &s2, l2+1, &mbs) == (size_t)-1 )
+  { rc = 2;
+    goto out;
+  }
+  if ( icase )
+  { wstolower(w1, l1);
+    wstolower(w2, l2);
+  }
+
+  rc = wcscoll(w1, w2);
+
+out:
+  if ( ml1 ) PL_free(w1);
+  if ( ml2 ) PL_free(w2);
+
+  return rc;
+}
+#endif

library/dialect/swi/os/pl-version.c

@@ -0,0 +1,36 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        wielemak@science.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2007, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "pl-incl.h"
+#ifdef USE_GIT_VERSION_H
+#include <version.h>
+#endif
+
+void
+setGITVersion(void)
+{
+#ifdef GIT_VERSION
+  PL_set_prolog_flag("version_git", PL_ATOM|FF_READONLY, GIT_VERSION);
+#endif
+}

library/dialect/swi/os/pl-write.c

@@ -0,0 +1,799 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2010, University of Amsterdam
+			      Vu University Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+/** @defgroup Write Outputting a term to a Stream
+ *  @ingroup InputOutput
+ *
+ * @brief Predicates that output a term to a stream. The predicates
+ * call upon write_term/3 to do the actual work. They differ on the
+ * parameters being used
+ * whether they write to user_output or to an user-specified stream.
+ *
+ * @{
+ */
+#include <math.h>
+#include "pl-incl.h"
+#include "pl-dtoa.h"
+#include "pl-ctype.h"
+#include <stdio.h>			/* sprintf() */
+#ifdef HAVE_LOCALE_H
+#include <locale.h>
+#endif
+#ifdef HAVE_FLOAT_H
+#include <float.h>
+#endif
+#ifdef HAVE_IEEEFP_H
+#include <ieeefp.h>
+#endif
+
+#ifdef fpclassify
+#define HAVE_FPCLASSIFY 1
+#endif
+
+#if __YAP_PROLOG__
+
+#define _PL_WRITE_ 1
+
+#include "yapio.h"
+
+#endif
+
+typedef struct visited
+{ Word address;				/* we have done this address */
+  struct visited *next;			/* next already visited */
+} visited;
+
+typedef struct
+{ int   flags;				/* PL_WRT_* flags */
+  int   max_depth;			/* depth limit */
+  int   depth;				/* current depth */
+  atom_t spacing;			/* Where to insert spaces */
+  module_t module;			/* Module for operators */
+  IOSTREAM *out;			/* stream to write to */
+  term_t portray_goal;			/* call/2 activated portray hook */
+  term_t write_options;			/* original write options */
+  term_t prec_opt;			/* term in write options with prec */
+} write_options;
+
+/** @pred  nl(+ _S_) is iso
+
+Outputs a new line to stream  _S_.
+ */
+/// @memberof nl/1
+word
+pl_nl1(term_t stream)
+{ GET_LD
+  IOSTREAM *s;
+
+  if ( getTextOutputStream(stream, &s) )
+  { Sputcode('\n', s);
+    return streamStatus(s);
+  }
+
+  fail;
+}
+
+/** @pred  nl is iso
+
+Outputs a new line to the current output stream.
+
+ */
+/// @memberof  nl/0
+word
+pl_nl(void)
+{ return pl_nl1(0);
+}
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Formatting a float. This used  to  use   sprintf(),  but  there  are two
+problems with this. First of all, this uses the current locale, which is
+complicated to avoid. Second, it does not provide a mode that guarantees
+reliable read-back. Using %g gets closest,   but %.15g doesn't guarantee
+read-back and %.17g does, but prints 0.1 as 0.100..001, etc.
+
+This uses dtoa.c. See pl-dtoa.c for how this is packed into SWI-Prolog.
+
+TBD: The number of cases are large. We should see whether it is possible
+to clean this up a bit. The 5 cases   as  such are real: there is no way
+around these.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+char *
+format_float(double f, char *buf)
+{ char *end, *o=buf;
+  int decpt, sign;
+  char *s = dtoa(f, 0, 30, &decpt, &sign, &end);
+
+  DEBUG(2, Sdprintf("decpt=%d, sign=%d, len = %d, '%s'\n",
+		    decpt, sign, end-s, s));
+
+  if ( sign )
+    *o++ = '-';
+
+  if ( decpt <= 0 )			/* decimal dot before */
+  { if ( decpt <= -4 )
+    { *o++ = s[0];
+      *o++ = '.';
+      if ( end-s > 1 )
+      { memcpy(o, s+1, end-s-1);
+	o += end-s-1;
+      } else
+	*o++ = '0';
+      sprintf(o, "e%d", decpt-1);
+    } else
+    { int i;
+
+      *o++ = '0';
+      *o++ = '.';
+      for(i=0; i < -decpt; i++)
+	*o++ = '0';
+      memcpy(o, s, end-s);
+      o[end-s] = 0;
+    }
+  } else if ( end-s > decpt )		/* decimal dot inside */
+  { memcpy(o, s, decpt);
+    o += decpt;
+    *o++ = '.';
+    memcpy(o, s+decpt, end-s-decpt);
+    o[end-s-decpt] = 0;
+  } else				/* decimal dot after */
+  { int i;
+    int trailing = decpt-(int)(end-s);
+
+    if ( decpt > 15 )			/* over precision: use eE */
+    { *o++ = s[0];
+      *o++ = '.';
+      if ( end-s > 1 )
+      { trailing += (int)(end-s)-1;
+	memcpy(o, s+1, end-s-1);
+	o += end-s-1;
+      } else
+	*o++ = '0';
+      sprintf(o, "e+%d", trailing);
+    } else				/* within precision trail with .0 */
+    { memcpy(o, s, end-s);
+      o += end-s;
+
+      for(i=(int)(end-s); i<decpt; i++)
+	*o++ = '0';
+      *o++ = '.';
+      *o++ = '0';
+      *o = 0;
+    }
+  }
+
+  freedtoa(s);
+
+  return buf;
+}
+
+static int
+bind_varnames(term_t varnames ARG_LD)
+{
+  CACHE_REGS
+  Term t = Yap_GetFromSlot(varnames);
+  while(!IsVarTerm(t) && IsPairTerm(t)) {
+    Term tl = HeadOfTerm(t);
+    Functor f;
+    Term tv, t2, t1;
+
+    if (!IsApplTerm(tl)) return FALSE;
+    if ((f = FunctorOfTerm(tl)) != FunctorEq) {
+      return FALSE;
+    }
+    t1 = ArgOfTerm(1, tl);
+    if (IsVarTerm(t1)) {
+      return PL_error(NULL, 0, "variable_names", ERR_INSTANTIATION, 0, t1);
+    }
+    t2 = ArgOfTerm(2, tl);
+    tv = Yap_MkApplTerm(LOCAL_FunctorVar, 1, &t1);
+    if (IsVarTerm(t2)) {
+      Bind_and_Trail(VarOfTerm(t2), tv);
+    }
+    t = TailOfTerm(t);
+  }
+  return TRUE;
+}
+
+char *
+varName(term_t t, char *name)
+{
+  CACHE_REGS
+  CELL *adr = (CELL *)Yap_GetFromSlot(t);
+
+  if (IsAttVar(adr)) {
+    Ssprintf(name, "_D%ld", (CELL)adr - (CELL)H0);
+  } else {
+    Ssprintf(name, "_%ld", (CELL)adr - (CELL)H0);
+  }
+
+  return name;
+}
+
+
+static bool
+writeTopTerm(term_t t, int prec, write_options *options)
+{
+  CACHE_REGS
+  UInt yap_flag = Use_SWI_Stream_f;
+  int flags = options->flags;
+  Term old_module;
+
+  if (flags & PL_WRT_QUOTED)
+    yap_flag |= Quote_illegal_f;
+  if (options->flags & PL_WRT_NUMBERVARS)
+    yap_flag |=  Handle_vars_f;
+  if (options->flags & PL_WRT_VARNAMES)
+    yap_flag |=  Handle_vars_f;
+  if (options->flags & PL_WRT_IGNOREOPS)
+    yap_flag |= Ignore_ops_f;
+  if (flags & PL_WRT_PORTRAY)
+    yap_flag |= Use_portray_f;
+  if (flags & PL_WRT_BACKQUOTED_STRING)
+    yap_flag |= BackQuote_String_f;
+  if (flags & PL_WRT_ATTVAR_IGNORE)
+    yap_flag |= 0L;
+  if (flags & PL_WRT_ATTVAR_DOTS)
+    yap_flag |= AttVar_Dots_f;
+  if (flags & PL_WRT_ATTVAR_PORTRAY)
+    yap_flag |= AttVar_Portray_f;
+  if (flags & PL_WRT_BLOB_PORTRAY)
+    yap_flag |= Blob_Portray_f;
+  old_module = CurrentModule;
+
+  CurrentModule = Yap_GetModuleFromEntry(options->module);
+
+Yap_plwrite(Yap_GetFromSlot(t), options->out, options->max_depth, yap_flag, prec);
+  CurrentModule = old_module;
+  return TRUE;
+}
+
+int
+writeAtomToStream(IOSTREAM *s, atom_t atom)
+{ Yap_WriteAtom( s, YAP_AtomFromSWIAtom(atom));
+  return 1;
+}
+
+static int
+writeBlobMask(atom_t a)
+{ if ( a == ATOM_default )
+  { return 0;
+  } else if ( a == ATOM_portray )
+  { return PL_WRT_BLOB_PORTRAY;
+  } else
+    return -1;
+}
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+PutOpenToken() inserts a space in the output stream if the last-written
+and given character require a space to ensure a token-break.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define TRUE_WITH_SPACE 2		/* OK, and emitted leading space before token */
+
+static bool
+Putc(int c, IOSTREAM *s)
+{ return Sputcode(c, s) == EOF ? FALSE : TRUE;
+}
+
+#define LAST_C_RESERVED		0x110000 /* Above Unicode range */
+#define PREFIX_SIGN		(LAST_C_RESERVED+1)
+
+#define isquote(c) ((c) == '\'' || (c) == '"')
+
+static bool
+needSpace(int c, IOSTREAM *s)
+{ if ( c == EOF )
+  { s->lastc = EOF;
+    return FALSE;
+  }
+
+  if ( s->lastc == PREFIX_SIGN )	/* avoid passing to is*W() functions */
+  { if ( isDigit(c) || isSymbolW(c) )
+      return TRUE;
+    return FALSE;
+  }
+
+  if ( s->lastc != EOF &&
+       ((isAlphaW(s->lastc) && isAlphaW(c)) ||
+	(isSymbolW(s->lastc) && isSymbolW(c)) ||
+	(s->lastc != '(' && !isBlank(s->lastc) && c == '(') ||
+	(c == '\'' && (isDigit(s->lastc))) ||
+	(isquote(c) && s->lastc == c)
+       ) )
+    return TRUE;
+
+  return FALSE;
+}
+
+
+static int
+PutOpenToken(int c, IOSTREAM *s)
+{ if ( needSpace(c, s) )
+  { TRY(Putc(' ', s));
+    return TRUE_WITH_SPACE;
+  }
+
+  return TRUE;
+}
+
+
+
+		 /*******************************
+		 *	      TOPLEVEL		*
+		 *******************************/
+
+int
+writeAttributeMask(atom_t a)
+{ if ( a == ATOM_ignore )
+  { return PL_WRT_ATTVAR_IGNORE;
+  } else if ( a == ATOM_dots )
+  { return PL_WRT_ATTVAR_DOTS;
+  } else if ( a == ATOM_write )
+  { return PL_WRT_ATTVAR_WRITE;
+  } else if ( a == ATOM_portray )
+  { return PL_WRT_ATTVAR_PORTRAY;
+  } else
+    return 0;
+}
+
+
+static const opt_spec write_term_options[] =
+{ { ATOM_quoted,	    OPT_BOOL },
+  { ATOM_ignore_ops,	    OPT_BOOL },
+  { ATOM_numbervars,        OPT_BOOL },
+  { ATOM_portray,           OPT_BOOL },
+  { ATOM_portray_goal,      OPT_TERM },
+  { ATOM_character_escapes, OPT_BOOL },
+  { ATOM_max_depth,	    OPT_INT  },
+  { ATOM_module,	    OPT_ATOM },
+  { ATOM_backquoted_string, OPT_BOOL },
+  { ATOM_attributes,	    OPT_ATOM },
+  { ATOM_priority,	    OPT_INT },
+  { ATOM_partial,	    OPT_BOOL },
+  { ATOM_spacing,	    OPT_ATOM },
+  { ATOM_blobs,		    OPT_ATOM },
+  { ATOM_cycles,	    OPT_BOOL },
+  { ATOM_variable_names,    OPT_TERM },
+  { NULL_ATOM,		    0 }
+};
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Call user:portray/1 if defined.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+static int
+put_write_options(term_t opts_in, write_options *options)
+{ GET_LD
+  term_t newlist = PL_new_term_ref();
+  term_t precopt = PL_new_term_ref();
+  fid_t fid = PL_open_foreign_frame();
+  term_t head = PL_new_term_ref();
+  term_t tail = PL_copy_term_ref(opts_in);
+  term_t newhead = PL_new_term_ref();
+  term_t newtail = PL_copy_term_ref(newlist);
+  int rc = TRUE;
+
+  while(rc && PL_get_list(tail, head, tail))
+  { if ( !PL_is_functor(head, FUNCTOR_priority1) )
+      rc = ( PL_unify_list(newtail, newhead, newtail) &&
+	     PL_unify(newhead, head) );
+  }
+
+  if ( rc )
+  { rc = ( PL_unify_list(newtail, head, newtail) &&
+	   PL_unify_functor(head, FUNCTOR_priority1) &&
+	   PL_get_arg(1, head, precopt) &&
+	   PL_unify_nil(newtail) );
+  }
+  if ( rc )
+  { options->write_options = newlist;
+    options->prec_opt = precopt;
+  }
+
+  PL_close_foreign_frame(fid);
+  return rc;
+}
+
+word
+pl_write_term3(term_t stream, term_t term, term_t opts)
+{ GET_LD
+  bool quoted     = FALSE;
+  bool ignore_ops = FALSE;
+  int numbervars = -1;			/* not set */
+  bool portray    = FALSE;
+  term_t gportray = 0;
+  bool bqstring   = truePrologFlag(PLFLAG_BACKQUOTED_STRING);
+  int charescape = -1;			/* not set */
+  atom_t mname    = ATOM_user;
+  atom_t attr     = ATOM_nil;
+  atom_t blobs    = ATOM_nil;
+  int  priority   = 1200;
+  bool partial    = FALSE;
+  bool cycles     = TRUE;
+  term_t varnames = 0;
+  int local_varnames;
+  IOSTREAM *s = NULL;
+  write_options options;
+  int rc;
+
+  memset(&options, 0, sizeof(options));
+  options.spacing = ATOM_standard;
+
+  if ( !scan_options(opts, 0, ATOM_write_option, write_term_options,
+		     &quoted, &ignore_ops, &numbervars, &portray, &gportray,
+		     &charescape, &options.max_depth, &mname,
+		     &bqstring, &attr, &priority, &partial, &options.spacing,
+		     &blobs, &cycles, &varnames) )
+    fail;
+
+  if ( attr == ATOM_nil )
+  { options.flags |= LD->prolog_flag.write_attributes;
+  } else
+  { int mask = writeAttributeMask(attr);
+
+    if ( !mask )
+      return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts);
+
+    options.flags |= mask;
+  }
+  if ( blobs != ATOM_nil )
+  { int mask = writeBlobMask(blobs);
+
+    if ( mask < 0 )
+      return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts);
+
+    options.flags |= mask;
+  }
+  if ( priority < 0 || priority > OP_MAXPRIORITY )
+  { term_t t = PL_new_term_ref();
+    PL_put_integer(t, priority);
+
+    return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_operator_priority, t);
+  }
+  switch( options.spacing )
+  { case ATOM_standard:
+    case ATOM_next_argument:
+      break;
+    default:
+    { term_t t = PL_new_term_ref();
+      PL_put_atom(t, options.spacing);
+
+      return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_spacing, t);
+    }
+  }
+
+  options.module = lookupModule(mname);
+  if ( charescape == TRUE ||
+       (charescape == -1
+#ifndef __YAP_PROLOG__
+&& True(options.module, M_CHARESCAPE)
+#endif
+	) )
+    options.flags |= PL_WRT_CHARESCAPES;
+  if ( gportray )
+  { options.portray_goal = gportray;
+    if ( !put_write_options(opts, &options) ||
+	 !PL_qualify(options.portray_goal, options.portray_goal) )
+      return FALSE;
+    portray = TRUE;
+  }
+  if ( numbervars == -1 )
+    numbervars = (portray ? TRUE : FALSE);
+
+  if ( quoted )     options.flags |= PL_WRT_QUOTED;
+  if ( ignore_ops ) options.flags |= PL_WRT_IGNOREOPS;
+  if ( numbervars ) options.flags |= PL_WRT_NUMBERVARS;
+  if ( portray )    options.flags |= PL_WRT_PORTRAY;
+  if ( bqstring )   options.flags |= PL_WRT_BACKQUOTED_STRING;
+  if ( !cycles )    options.flags |= PL_WRT_NO_CYCLES;
+
+  local_varnames = (varnames && False(&options, PL_WRT_NUMBERVARS));
+
+  BEGIN_NUMBERVARS(local_varnames);
+  if ( varnames )
+      { if ( (rc=bind_varnames(varnames PASS_LD)) )
+      options.flags |= PL_WRT_VARNAMES;
+    else
+      goto out;
+  }
+  if ( !(rc=getTextOutputStream(stream, &s)) )
+    goto out;
+
+  options.out = s;
+  if ( !partial )
+    PutOpenToken(EOF, s);		/* reset this */
+  if ( (options.flags & PL_WRT_QUOTED) && !(s->flags&SIO_REPPL) )
+  { s->flags |= SIO_REPPL;
+    rc = writeTopTerm(term, priority, &options);
+    s->flags &= ~SIO_REPPL;
+  } else
+  { rc = writeTopTerm(term, priority, &options);
+  }
+
+out:
+  END_NUMBERVARS(local_varnames);
+
+  return (!s || streamStatus(s)) && rc;
+}
+
+/** @pred  write_term(+ _S_, + _T_, + _Opts_) is iso
+
+Displays term  _T_ on the current output stream, according to the same
+options used by `write_term/3`.
+
+
+*/
+/// @memberof write_term/3
+word
+pl_write_term(term_t term, term_t options)
+{ return pl_write_term3(0, term, options);
+}
+
+/** @pred  write_term(+ _T_, + _Opts_) is iso
+
+
+    Displays term  _T_ on the current output stream, according to the
+following options:
+
++ quoted(+ _Bool_) is iso
+
+    If `true`, quote atoms if this would be necessary for the atom to
+be recognized as an atom by YAP's parser. The default value is
+`false`.
+
++ ignore_ops(+ _Bool_) is iso
+
+   If `true`, ignore operator declarations when writing the term. The
+default value is `false`.
+
++ numbervars(+ _Bool_) is iso
+
+    If `true`, output terms of the form
+`$VAR(N)`, where  _N_ is an integer, as a sequence of capital
+letters. The default value is `false`.
+
++ portrayed(+ _Bool_)
+
+    If `true`, use <tt>portray/1</tt> to portray bound terms. The default
+value is `false`.
+
++ portray(+ _Bool_)
+
+    If `true`, use <tt>portray/1</tt> to portray bound terms. The default
+value is `false`.
+
++ max_depth(+ _Depth_)
+
+    If `Depth` is a positive integer, use <tt>Depth</tt> as
+the maximum depth to portray a term. The default is `0`, that is,
+unlimited depth.
+
++ priority(+ _Piority_)
+
+    If `Priority` is a positive integer smaller than `1200`,
+give the context priority. The default is `1200`.
+
++ cycles(+ _Bool_)
+
+    Do not loop in rational trees (default).
+
+*/
+/// @memberof write_term/2
+int
+PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags)
+{ write_options options;
+
+  memset(&options, 0, sizeof(options));
+  options.flags	    = flags;
+  options.out	    = s;
+  options.module    = MODULE_user;
+  PutOpenToken(EOF, s);			/* reset this */
+  return writeTopTerm(term, precedence, &options);
+}
+
+
+static word
+do_write2(term_t stream, term_t term, int flags)
+{ GET_LD
+  IOSTREAM *s;
+
+  if ( getTextOutputStream(stream, &s) )
+  { write_options options;
+    int rc;
+
+    memset(&options, 0, sizeof(options));
+    options.flags     = flags;
+    options.out	      = s;
+    options.module    = MODULE_user;
+    if ( options.module
+#ifndef __YAP_PROLOG__
+	 && True(options.module, M_CHARESCAPE)
+#endif
+	 )
+      options.flags |= PL_WRT_CHARESCAPES;
+    if ( truePrologFlag(PLFLAG_BACKQUOTED_STRING) )
+      options.flags |= PL_WRT_BACKQUOTED_STRING;
+
+    PutOpenToken(EOF, s);		/* reset this */
+    rc = writeTopTerm(term, 1200, &options);
+    if ( rc && (flags&PL_WRT_NEWLINE) )
+      rc = Putc('\n', s);
+
+    return streamStatus(s) && rc;
+  }
+
+  return FALSE;
+}
+
+
+/** @pred  write(+ _S_, _T_) is iso
+
+Writes term  _T_ to stream  _S_ instead of to the current output
+stream.
+
+
+*/
+/// @memberof write/2
+word
+pl_write2(term_t stream, term_t term)
+{ return do_write2(stream, term, PL_WRT_NUMBERVARS);
+}
+
+/** @pred  writeq(+ _S_, _T_) is iso
+
+As writeq/1, but the output is sent to the stream  _S_.
+
+
+*/
+/// @memberof writeq/2
+word
+pl_writeq2(term_t stream, term_t term)
+{ return do_write2(stream, term, PL_WRT_QUOTED|PL_WRT_NUMBERVARS);
+}
+
+/** @pred  print(+ _S_, _T_)
+
+Prints term  _T_ to the stream  _S_ instead of to the current output
+stream.
+
+
+*/
+/// @memberof print/2
+word
+pl_print2(term_t stream, term_t term)
+{ return do_write2(stream, term,
+		   PL_WRT_PORTRAY|PL_WRT_NUMBERVARS);
+}
+
+/** @pred  write_canonical(+ _S_,+ _T_) is iso
+
+Displays term  _T_ on the stream  _S_. Atoms are quoted when
+necessary, and operators are ignored.
+
+
+*/
+/// @memberof write_canonical/2
+word
+pl_write_canonical2(term_t stream, term_t term)
+{ GET_LD
+  nv_options options;
+  word rc;
+
+  BEGIN_NUMBERVARS(TRUE);
+
+  options.functor = FUNCTOR_isovar1;
+  options.on_attvar = AV_SKIP;
+  options.singletons = PL_is_acyclic(term);
+  options.numbered_check = FALSE;
+
+  rc = ( numberVars(term, &options, 0 PASS_LD) >= 0 &&
+	 do_write2(stream, term,
+		   PL_WRT_QUOTED|PL_WRT_IGNOREOPS|PL_WRT_NUMBERVARS|PLFLAG_BACKQUOTED_STRING)
+       );
+
+  END_NUMBERVARS(TRUE);
+
+  return rc;
+}
+
+/** @pred  write( _T_) is iso
+
+
+The term  _T_ is written to the current output stream according to
+the operator declarations in force.
+*/
+/// @memberof write/1
+word
+pl_write(term_t term)
+{ return pl_write2(0, term);
+}
+
+word
+/** @pred  writeq( _T_) is iso
+
+Writes the term  _T_, quoting names to make the result acceptable to
+the predicate `read` whenever necessary.
+*/
+/// @memberof writeq/1
+pl_writeq(term_t term)
+{ return pl_writeq2(0, term);
+}
+
+/** @pred  print( _T_)
+
+
+Prints the term  _T_ to the current output stream using write/1
+unless T is bound and a call to the user-defined  predicate
+`portray/1` succeeds. To do pretty  printing of terms the user should
+define suitable clauses for `portray/1` and use print/1.
+
+
+*/
+/// @memberof print/1
+word
+pl_print(term_t term)
+{ return pl_print2(0, term);
+}
+
+/** @pred  write_canonical(+ _T_) is iso
+
+
+Displays term  _T_ on the current output stream. Atoms are quoted
+when necessary, and operators are ignored, that is, the term is written
+in standard parenthesized prefix notation.
+
+
+*/
+/// @memberof write_canonical/1
+word
+pl_write_canonical(term_t term)
+{ return pl_write_canonical2(0, term);
+}
+
+/** @pred  writeln( _T_)
+
+
+Prints the term  _T_ to the current output stream using write/1,
+followed by a newline.
+
+
+*/
+/// @memberof writeln/1
+word
+pl_writeln(term_t term)
+{ return do_write2(0, term, PL_WRT_NUMBERVARS|PL_WRT_NEWLINE);
+}
+
+
+
+		 /*******************************
+		 *      PUBLISH PREDICATES	*
+		 *******************************/
+/// @}
+
+BeginPredDefs(write)
+EndPredDefs

library/dialect/swi/os/windows/README

@@ -0,0 +1,8 @@
+The UXNT.LIB library is used SWI-Prolog and XPCE   to make the NT and 95
+filesystem a bit more like the Unix one. It deals with mapping directory
+separators, ensuring there are only single   separators (mapping // to \
+for example) that root-directories of devices   (c:/,  etc.) are handled
+properly, no matter how the name is formed. It also implemends readdir()
+and friends for Unix-compatible access to the directory.
+
+	Regards --- Jan

library/dialect/swi/os/windows/dirent.h

@@ -0,0 +1,51 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#ifndef _DIRENT_H_INCLUDED
+#define _DIRENT_H_INCLUDED
+
+#include <io.h>
+
+#undef _export
+#if defined(_UXNT_KERNEL) && !defined(__MINGW32__)
+#define _export _declspec(dllexport)
+#else
+#define _export extern
+#endif
+
+#define DIRENT_MAX 512
+
+typedef struct dirent
+{ void *		data;		/* actually WIN32_FIND_DATA * */
+  int			first;
+  void *		handle;		/* actually HANDLE */
+					/* dirent */
+  char			d_name[DIRENT_MAX+1];
+} DIR;
+
+_export DIR *		opendir(const char *path);
+_export int		closedir(DIR *dp);
+_export struct dirent *	readdir(DIR *dp);
+
+#endif /*_DIRENT_H_INCLUDED*/

library/dialect/swi/os/windows/popen.c

@@ -0,0 +1,364 @@
+/* popen.c
+  RunSilent() is by Steven Szelei,
+  and pt_popen()/pt_pclose() is by Kurt Keller
+  Modified and comments translated by Steve Donovan
+
+  Please note an extension; if your commmand contains '2>&1'
+  then any error output will be redirected as well to the pipe.
+
+  Put this file in scite\lua\src\lib and add to your project
+
+  to modify liolib.c in the same dir,
+  replace conditional at line 47 with:
+
+  #ifndef USE_POPEN
+  #ifdef __WINDOWS__
+  #define USE_POPEN 1
+  FILE* pt_popen(const char *cmd, const char*mode);
+  int pt_pclose(FILE *file);
+  uintptr_t RunSilent(const char* strCommand);
+  #define popen pt_popen
+  #define pclose pt_pclose
+  #define system RunSilent
+  #endif
+  #else
+  #define USE_POPEN	0
+  #endif
+
+*/
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+SWI-Prolog note:
+
+This        file        is         copied          verbatim         from
+http://lua-users.org/wiki/PipesOnWindows, where it is   contributed  for
+using pipes with the LUA programming  language. LUA is distributed under
+the MIT licence which is claimed to be compatible (but less restrictive)
+with the LGPL license. We  therefore  assume   we  can  use this file in
+SWI-Prolog without introducing new license problems.
+
+This version is heavily modified:
+
+	* Support Unicode commands (commands are specified in UTF-8)
+	* make popen()/pclose() thread-safe.
+	* Fix leak process-handles
+
+If you find this file and know better, please contact info@swi-prolog.org.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#include <windows.h>
+#include <stdio.h>
+#include <fcntl.h>
+#include <string.h>
+#include <io.h>
+#include "pl-utf8.h"
+
+DWORD RunSilent(const char* strCommand);
+FILE *pt_popen(const char *cmd, const char *mode);
+int pt_pclose(FILE *fd);
+
+
+DWORD RunSilent(const char* strCommand)
+{
+	STARTUPINFO StartupInfo;
+	PROCESS_INFORMATION ProcessInfo;
+	char Args[4096];
+	char *pEnvCMD = NULL;
+	char *pDefaultCMD = "CMD.EXE";
+	ULONG rc;
+
+	memset(&StartupInfo, 0, sizeof(StartupInfo));
+	StartupInfo.cb = sizeof(STARTUPINFO);
+	StartupInfo.dwFlags = STARTF_USESHOWWINDOW;
+	StartupInfo.wShowWindow = SW_HIDE;
+
+	Args[0] = 0;
+
+	pEnvCMD = getenv("COMSPEC");
+
+	if(pEnvCMD){
+		strcpy(Args, pEnvCMD);
+	} else{
+		strcpy(Args, pDefaultCMD);
+	}
+
+	/* "/c" option - Do the command then terminate the command window */
+	strcat(Args, " /c ");
+	/*the application you would like to run from the command window */
+	strcat(Args, strCommand);
+
+	if (!CreateProcess( NULL, Args, NULL, NULL, FALSE,
+		CREATE_NEW_CONSOLE,
+		NULL,
+		NULL,
+		&StartupInfo,
+		&ProcessInfo))
+	{
+		return GetLastError();
+	}
+
+	WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
+	if(!GetExitCodeProcess(ProcessInfo.hProcess, &rc))
+		rc = 0;
+
+	CloseHandle(ProcessInfo.hThread);
+	CloseHandle(ProcessInfo.hProcess);
+
+	return rc;
+
+}
+
+/*------------------------------------------------------------------------------
+  Globals for the Routines pt_popen() / pt_pclose()
+------------------------------------------------------------------------------*/
+
+CRITICAL_SECTION lock;
+#define LOCK()   EnterCriticalSection(&lock);
+#define UNLOCK() LeaveCriticalSection(&lock);
+
+static void
+pt_init( void )
+{ InitializeCriticalSection(&lock);
+}
+
+
+typedef struct pipe_context
+{ struct pipe_context *next;
+  FILE   *fd;
+  HANDLE in[2];
+  HANDLE out[2];
+  HANDLE err[2];
+  char   mode;				/* 'r' or 'w' */
+} pipe_context;
+
+
+static pipe_context *pipes = NULL;
+
+static pipe_context *
+allocPipeContext( void )
+{ pipe_context *pc = malloc(sizeof(*pc));
+
+  if ( !pc )
+    return NULL;
+
+  pc->in[0]   = INVALID_HANDLE_VALUE;
+  pc->in[1]   = INVALID_HANDLE_VALUE;
+  pc->out[0]  = INVALID_HANDLE_VALUE;
+  pc->out[1]  = INVALID_HANDLE_VALUE;
+  pc->err[0]  = INVALID_HANDLE_VALUE;
+  pc->err[1]  = INVALID_HANDLE_VALUE;
+
+  return pc;
+}
+
+
+static void
+discardPipeContext(pipe_context *pc)
+{ if (pc->in[0]  != INVALID_HANDLE_VALUE)
+    CloseHandle(pc->in[0]);
+  if (pc->in[1]  != INVALID_HANDLE_VALUE)
+    CloseHandle(pc->in[1]);
+  if (pc->out[0] != INVALID_HANDLE_VALUE)
+    CloseHandle(pc->out[0]);
+  if (pc->out[1] != INVALID_HANDLE_VALUE)
+    CloseHandle(pc->out[1]);
+  if (pc->err[0] != INVALID_HANDLE_VALUE)
+    CloseHandle(pc->err[0]);
+  if (pc->err[1] != INVALID_HANDLE_VALUE)
+    CloseHandle(pc->err[1]);
+
+  free(pc);
+}
+
+
+
+static void
+linkPipeContext(pipe_context *pc)
+{ LOCK();
+  pc->next = pipes;
+  pipes = pc;
+  UNLOCK();
+}
+
+
+static int
+my_pipe(HANDLE *readwrite)
+{
+  SECURITY_ATTRIBUTES sa;
+
+  sa.nLength = sizeof(sa);          /* Length in bytes */
+  sa.bInheritHandle = 1;            /* the child must inherit these handles */
+  sa.lpSecurityDescriptor = NULL;
+
+  if (! CreatePipe (&readwrite[0],&readwrite[1],&sa,1 << 13))
+  {
+    errno = -1; /* EMFILE; que? */
+    return -1;
+  }
+
+  return 0;
+}
+
+/*------------------------------------------------------------------------------
+  Replacement for 'popen()' under Windows.
+
+  cmd is taken to be encoded in UTF-8 for compatibility with the Unix
+  version.
+
+  NOTE: if cmd contains '2>&1', we connect the standard error file handle
+    to the standard output file handle.
+------------------------------------------------------------------------------*/
+
+static void
+utf8towcs(wchar_t *o, const char *src)
+{ for( ; *src; )
+  { int wc;
+
+    src = utf8_get_char(src, &wc);
+    *o++ = wc;
+  }
+  *o = 0;
+}
+
+
+FILE *
+pt_popen(const char *cmd, const char *mode)
+{ FILE *fptr = NULL;
+  PROCESS_INFORMATION piProcInfo;
+  STARTUPINFOW siStartInfo;
+  int success, redirect_error = 0;
+  wchar_t *wcmd = NULL;
+  wchar_t *err2out;
+  pipe_context *pc;
+
+  size_t utf8len = utf8_strlen(cmd, strlen(cmd));
+  if ( !(wcmd = malloc((utf8len+1)*sizeof(wchar_t))) )
+  { return NULL;
+  }
+  utf8towcs(wcmd, cmd);
+
+  if ( !(pc=allocPipeContext()) )
+    goto finito;
+  if ( !mode || !*mode )
+    goto finito;
+  pc->mode = *mode;
+  if ( pc->mode != 'r' && pc->mode != 'w' )
+    goto finito;
+
+  /*
+   * Shall we redirect stderr to stdout ? */
+  if ( (err2out=wcsstr(wcmd, L"2>&1")) != NULL)
+  { /* this option doesn't apply to win32 shells, so we clear it out! */
+     wcsncpy(err2out, L"    ", 4);
+     redirect_error = 1;
+  }
+
+  /*
+   * Create the Pipes... */
+  if (my_pipe(pc->in)  == -1 ||
+      my_pipe(pc->out) == -1)
+    goto finito;
+  if ( !redirect_error )
+  { if ( my_pipe(pc->err) == -1)
+      goto finito;
+  }
+
+  /*
+   * Now create the child process */
+  ZeroMemory(&siStartInfo, sizeof(STARTUPINFO));
+  siStartInfo.cb           = sizeof(STARTUPINFO);
+  siStartInfo.hStdInput    = pc->in[0];
+  siStartInfo.hStdOutput   = pc->out[1];
+  if ( redirect_error )
+    siStartInfo.hStdError  = pc->out[1];
+  else
+    siStartInfo.hStdError  = pc->err[1];
+  siStartInfo.dwFlags      = STARTF_USESTDHANDLES;
+
+  success = CreateProcessW(NULL,
+			   wcmd,	// command line
+			   NULL,	// process security attributes
+			   NULL,	// primary thread security attributes
+			   TRUE,	// handles are inherited
+			   CREATE_NO_WINDOW,  // creation flags: without window (?)
+			   NULL,	// use parent's environment
+			   NULL,	// use parent's current directory
+			   &siStartInfo, // STARTUPINFO pointer
+			   &piProcInfo); // receives PROCESS_INFORMATION
+
+  if ( !success )
+    goto finito;
+
+  CloseHandle(piProcInfo.hThread);
+  CloseHandle(piProcInfo.hProcess);
+
+  /*
+   * These handles listen to the Child process */
+  CloseHandle(pc->in[0]);  pc->in[0]  = INVALID_HANDLE_VALUE;
+  CloseHandle(pc->out[1]); pc->out[1] = INVALID_HANDLE_VALUE;
+  if ( pc->err[1] != INVALID_HANDLE_VALUE )
+  { CloseHandle(pc->err[1]);
+    pc->err[1] = INVALID_HANDLE_VALUE;
+  }
+
+  if ( pc->mode == 'r' )
+    fptr = _fdopen(_open_osfhandle((intptr_t)pc->out[0],_O_BINARY),"r");
+  else
+    fptr = _fdopen(_open_osfhandle((intptr_t)pc->in[1],_O_BINARY),"w");
+
+finito:
+  if ( fptr )
+  { pc->fd = fptr;
+    linkPipeContext(pc);
+  } else
+  { if ( pc )
+      discardPipeContext(pc);
+  }
+  if ( wcmd )
+    free(wcmd);
+
+  return fptr;
+}
+
+/*------------------------------------------------------------------------------
+  Replacement for 'pclose()' under Win32
+------------------------------------------------------------------------------*/
+int
+pt_pclose(FILE *fd)
+{ pipe_context **ppc;
+  int rc;
+
+  if ( !fd )
+  { errno = EINVAL;
+    return -1;
+  }
+
+  rc = fclose(fd);
+  LOCK();
+  for(ppc = &pipes; *ppc; ppc=&(*ppc)->next)
+  { pipe_context *pc = *ppc;
+
+    if ( pc->fd == fd )
+    { *ppc = pc->next;
+
+      UNLOCK();
+      if ( pc->err[0] != INVALID_HANDLE_VALUE )
+	CloseHandle(pc->err[0]);
+      if ( pc->mode == 'r' )
+      { CloseHandle(pc->in[1]);
+      } else
+      { CloseHandle(pc->out[0]);
+      }
+
+      free(pc);
+
+      return rc;
+    }
+  }
+
+  UNLOCK();
+  errno = EINVAL;
+  return -1;
+}
+
+

library/dialect/swi/os/windows/utf8.c

@@ -0,0 +1,101 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker and Anjo Anjewierden
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+#include "utf8.h"
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+UTF-8 Decoding, based on http://www.cl.cam.ac.uk/~mgk25/unicode.html
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define CONT(i)   ISUTF8_CB(in[1])
+#define VAL(i, s) ((in[i]&0x3f) << s)
+
+static char *
+_xos_utf8_get_char(const char *in, int *chr)
+{ 					/* 2-byte, 0x80-0x7ff */
+  if ( (in[0]&0xe0) == 0xc0 && CONT(1) )
+  { *chr = ((in[0]&0x1f) << 6)|VAL(1,0);
+    return (char *)in+2;
+  }
+					/* 3-byte, 0x800-0xffff */
+  if ( (in[0]&0xf0) == 0xe0 && CONT(1) && CONT(2) )
+  { *chr = ((in[0]&0xf) << 12)|VAL(1,6)|VAL(2,0);
+    return (char *)in+3;
+  }
+					/* 4-byte, 0x10000-0x1FFFFF */
+  if ( (in[0]&0xf8) == 0xf0 && CONT(1) && CONT(2) && CONT(3) )
+  { *chr = ((in[0]&0x7) << 18)|VAL(1,12)|VAL(2,6)|VAL(3,0);
+    return (char *)in+4;
+  }
+					/* 5-byte, 0x200000-0x3FFFFFF */
+  if ( (in[0]&0xfc) == 0xf8 && CONT(1) && CONT(2) && CONT(3) && CONT(4) )
+  { *chr = ((in[0]&0x3) << 24)|VAL(1,18)|VAL(2,12)|VAL(3,6)|VAL(4,0);
+    return (char *)in+5;
+  }
+					/* 6-byte, 0x400000-0x7FFFFFF */
+  if ( (in[0]&0xfe) == 0xfc && CONT(1) && CONT(2) && CONT(3) && CONT(4) && CONT(5) )
+  { *chr = ((in[0]&0x1) << 30)|VAL(1,24)|VAL(2,18)|VAL(3,12)|VAL(4,6)|VAL(5,0);
+    return (char *)in+4;
+  }
+
+  *chr = *in;
+
+  return (char *)in+1;
+}
+
+
+static char *
+_xos_utf8_put_char(char *out, int chr)
+{ if ( chr < 0x80 )
+  { *out++ = chr;
+  } else if ( chr < 0x800 )
+  { *out++ = 0xc0|((chr>>6)&0x1f);
+    *out++ = 0x80|(chr&0x3f);
+  } else if ( chr < 0x10000 )
+  { *out++ = 0xe0|((chr>>12)&0x0f);
+    *out++ = 0x80|((chr>>6)&0x3f);
+    *out++ = 0x80|(chr&0x3f);
+  } else if ( chr < 0x200000 )
+  { *out++ = 0xf0|((chr>>18)&0x07);
+    *out++ = 0x80|((chr>>12)&0x3f);
+    *out++ = 0x80|((chr>>6)&0x3f);
+    *out++ = 0x80|(chr&0x3f);
+  } else if ( chr < 0x4000000 )
+  { *out++ = 0xf8|((chr>>24)&0x03);
+    *out++ = 0x80|((chr>>18)&0x3f);
+    *out++ = 0x80|((chr>>12)&0x3f);
+    *out++ = 0x80|((chr>>6)&0x3f);
+    *out++ = 0x80|(chr&0x3f);
+  } else if ( chr < 0x80000000 )
+  { *out++ = 0xfc|((chr>>30)&0x01);
+    *out++ = 0x80|((chr>>24)&0x3f);
+    *out++ = 0x80|((chr>>18)&0x3f);
+    *out++ = 0x80|((chr>>12)&0x3f);
+    *out++ = 0x80|((chr>>6)&0x3f);
+    *out++ = 0x80|(chr&0x3f);
+  }
+
+  return out;
+}
+

library/dialect/swi/os/windows/utf8.h

@@ -0,0 +1,58 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker and Anjo Anjewierden
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*/
+
+
+#ifndef UTF8_H_INCLUDED
+#define UTF8_H_INCLUDED
+
+#define UTF8_MALFORMED_REPLACEMENT 0xfffd
+
+#define ISUTF8_MB(c) ((unsigned)(c) >= 0xc0 && (unsigned)(c) <= 0xfd)
+
+#define ISUTF8_CB(c)  (((c)&0xc0) == 0x80) /* Is continuation byte */
+#define ISUTF8_FB2(c) (((c)&0xe0) == 0xc0)
+#define ISUTF8_FB3(c) (((c)&0xf0) == 0xe0)
+#define ISUTF8_FB4(c) (((c)&0xf8) == 0xf0)
+#define ISUTF8_FB5(c) (((c)&0xfc) == 0xf8)
+#define ISUTF8_FB6(c) (((c)&0xfe) == 0xfc)
+
+#define UTF8_FBN(c) (!(c&0x80)     ? 0 : \
+		     ISUTF8_FB2(c) ? 1 : \
+		     ISUTF8_FB3(c) ? 2 : \
+		     ISUTF8_FB4(c) ? 3 : \
+		     ISUTF8_FB5(c) ? 4 : \
+		     ISUTF8_FB6(c) ? 5 : -1)
+#define UTF8_FBV(c,n) ( n == 0 ? c : (c & ((0x01<<(6-n))-1)) )
+
+#define utf8_get_char(in, chr) \
+	(*(in) & 0x80 ? _xos_utf8_get_char(in, chr) \
+		      : (*(chr) = *(in), (char *)(in)+1))
+#define utf8_put_char(out, chr) \
+	((chr) < 0x80 ? out[0]=(char)(chr), out+1 \
+		      : _xos_utf8_put_char(out, (chr)))
+
+static char *_xos_utf8_get_char(const char *in, int *chr);
+static char *_xos_utf8_put_char(char *out, int chr);
+
+#endif /*UTF8_H_INCLUDED*/

library/dialect/swi/os/windows/uxnt.h

@@ -0,0 +1,161 @@
+/*  $Id$
+
+    Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        jan@swi.psy.uva.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (C): 1985-2002, University of Amsterdam
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library 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
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#ifndef _XNT_H_INCLUDED
+#define _XNT_H_INCLUDED
+
+#undef _export
+#if defined(_UXNT_KERNEL) && !defined(__MINGW32__)
+#define _export _declspec(dllexport)
+#else
+#define _export extern
+#endif
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <stdio.h>
+#include <io.h>
+#if HAVE_DIRECT_H
+#include <direct.h>
+#endif
+#if !defined(__MINGW32__) && !defined(__MSYS__)
+#if (_MSC_VER < 1300)
+typedef long intptr_t;
+typedef unsigned long uintptr_t;
+#endif
+typedef intptr_t ssize_t;		/* signed version of size_t */
+#endif
+
+#ifndef _UXNT_KERNEL
+
+#undef remove
+#undef rename
+#undef open
+#undef close
+#undef read
+#undef write
+#undef lseek
+#undef tell
+#undef access
+#undef chmod
+#undef remove
+#undef rename
+#undef stat
+#undef chdir
+#undef mkdir
+#undef rmdir
+#undef getcwd
+
+#define remove _xos_remove
+#define rename _xos_rename
+#define open _xos_open
+#define close _xos_close
+#define read _xos_read
+#define write _xos_write
+#define lseek _xos_lseek
+#define tell _xos_tell
+#define access _xos_access
+#define chmod _xos_chmod
+#define remove _xos_remove
+#define rename _xos_rename
+#define statfunc _xos_stat
+#define chdir _xos_chdir
+#define mkdir _xos_mkdir
+#define rmdir _xos_rmdir
+#define getcwd _xos_getcwd_i
+#define setenv _xos_setenv
+#define fopen(p, m) _xos_fopen(p, m)
+
+#endif /*_UXNT_KERNEL*/
+
+#if !defined(__MINGW32__) && !defined(__MSYS__)
+#define F_OK 00
+#define R_OK 04				/* access() fields */
+#define W_OK 06
+#endif
+
+		 /*******************************
+		 *	     TYPES, ETC		*
+		 *******************************/
+
+#ifndef PATH_MAX
+#define PATH_MAX 1024
+#endif
+
+#if __MSYS__
+#define _stati64 stat
+#endif
+
+#undef _xos_stat
+
+_export char *  _xos_home(void);
+_export wchar_t*_xos_os_filenameW(const char *cname,
+				  wchar_t *osname, size_t len);
+_export char *	_xos_os_filename(const char *cname,
+				 char *osname, size_t len);
+_export char *	_xos_canonical_filenameW(const wchar_t *cname,
+					 char *osname, size_t len, int flags);
+_export char *	_xos_canonical_filename(const char *cname,
+					char *osname, size_t len, int flags);
+_export int	_xos_is_absolute_filename(const char *spec);
+_export char *	_xos_absolute_filename(const char *local, char *absolute, size_t len);
+_export char *	_xos_limited_os_filename(const char *spec, char *limited);
+_export wchar_t*_xos_long_file_nameW(const wchar_t *n8and3,
+				     wchar_t *name, size_t len);
+_export char*	_xos_long_file_name_toA(const wchar_t *n8and3,
+					char *name, size_t len);
+_export char *  _xos_long_file_name(const char *file, char *longname,
+				    size_t len);
+_export int	_xos_same_file(const char *p1, const char *p2);
+_export int	_xos_open(const char *path, int access, ...);
+_export FILE*	_xos_fopen(const char *path, const char *mode);
+_export int	_xos_close(int handle);
+_export ssize_t	_xos_read(int handle, void *buf, size_t size);
+_export ssize_t	_xos_write(int handle, const void *buf, size_t size);
+_export long	_xos_lseek(int handle, long offset, int whence);
+_export long	_xos_tell(int handle);
+_export int	_xos_access(const char *path, int mode);
+_export int	_xos_chmod(const char *path, mode_t mode);
+_export int	_xos_remove(const char *path);
+_export int	_xos_rename(const char *old, const char *newname);
+_export int	_xos_stat(const char *path, struct _stati64 *sbuf);
+_export int	_xos_chdir(const char *path);
+_export int	_xos_mkdir(const char *path, int mode);
+_export int	_xos_rmdir(const char *path);
+_export char *	_xos_getcwd(char *buf, size_t len);
+_export char *	_xos_getcwd_i(char *buf, int len);
+_export int	_xos_errno(void);
+_export int	_xos_exists(const char *path, int flags);
+_export size_t  _xos_getenv(const char *name, char *buf, size_t buflen);
+_export int	_xos_setenv(const char *name, char *value, int overwrite);
+
+#define _XOS_ISFILE	0x01
+#define _XOS_ISDIR	0x02
+
+#define _XOS_FILE	0x0001		/* is a file */
+#define _XOS_DIR	0x0002		/* is a directory */
+
+#define XOS_DOWNCASE	0x01		/* _xos_canonical_filename() */
+
+#endif /*_XNT_H_INCLUDED*/