Merge branch 'master' of ssh://git.dcc.fc.up.pt/yap-6.3

C/compiler.c

@@ -2109,14 +2109,14 @@ c_head(Term t, compiler_struct *cglobs)
   if (IsAtomTerm(t)) {
     Yap_emit(name_op, (CELL) AtomOfTerm(t), Zero, &cglobs->cint);
 #ifdef BEAM
-   if (EAM) {
+    if (EAM) {
-     Yap_emit(run_op,Zero,(UInt) cglobs->cint.CurrentPred,&cglobs->cint);
+      Yap_emit(run_op,Zero,(UInt) cglobs->cint.CurrentPred,&cglobs->cint);
-   }
+    }
 #endif
+    Yap_emit(ensure_space_op, Zero , Zero, &cglobs->cint);
+    cglobs->space_op = cglobs->cint.cpc;
     return;
   }
-  Yap_emit(ensure_space_op, Zero , Zero, &cglobs->cint);
-  cglobs->space_op = cglobs->cint.cpc;
   f = FunctorOfTerm(t);
   Yap_emit(name_op, (CELL) NameOfFunctor(f), ArityOfFunctor(f), &cglobs->cint);
 #ifdef BEAM
@@ -2124,8 +2124,10 @@ c_head(Term t, compiler_struct *cglobs)
      Yap_emit(run_op,Zero,(UInt) cglobs->cint.CurrentPred,&cglobs->cint);
    }
 #endif
-   if (Yap_ExecutionMode == MIXED_MODE_USER)
+  if (Yap_ExecutionMode == MIXED_MODE_USER)
      Yap_emit(native_op, 0, 0, &cglobs->cint);
+  Yap_emit(ensure_space_op, Zero , Zero, &cglobs->cint);
+  cglobs->space_op = cglobs->cint.cpc;
   c_args(t, 0, cglobs);
 }
 
@@ -3537,6 +3539,10 @@ Yap_cclause(volatile Term inp_clause, Int NOfArgs, Term mod, volatile Term src)
     }
     if (LOCAL_ErrorMessage)
       return (0);
+    /* make sure we give enough space for the  fact */
+    if (cglobs.space_op)
+      cglobs.space_op->rnd1 = cglobs.space_used;
+
 #ifdef DEBUG
     if (GLOBAL_Option['g' - 96])
       Yap_ShowCode(&cglobs.cint);

C/pl-yap.c

@@ -476,14 +476,11 @@ int raiseStackOverflow(int overflow)
 		 *	    FEATURES		*
 		 *******************************/
 
-int
 PL_set_prolog_flag(const char *name, int type, ...)
 { va_list args;
   int rval = TRUE;
   int flags = (type & FF_MASK);
 
-  initPrologFlagTable();
-
   va_start(args, type);
   switch(type & ~FF_MASK)
   { case PL_BOOL:
@@ -494,10 +491,8 @@ PL_set_prolog_flag(const char *name, int type, ...)
     }
     case PL_ATOM:
     { const char *v = va_arg(args, const char *);
-#ifndef __YAP_PROLOG__
+      // VSC if ( !GD->initialised )
-      if ( !GD->initialised )
+      // VSC  initAtoms();
-	initAtoms();
-#endif
       setPrologFlag(name, FT_ATOM|flags, v);
       break;
     }
@@ -509,13 +504,12 @@ PL_set_prolog_flag(const char *name, int type, ...)
     default:
       rval = FALSE;
   }
-
   va_end(args);
+
   return rval;
 }
 
 
-
 int
 PL_unify_chars(term_t t, int flags, size_t len, const char *s)
 { PL_chars_t text;
@@ -761,6 +755,12 @@ PL_get_list_nchars(term_t l, size_t *length, char **s, unsigned int flags)
   fail;
 }
 
+void *
+PL_malloc_uncollectable(size_t sz)
+{
+  return malloc(sz);
+}
+
 int
 PL_get_list_chars(term_t l, char **s, unsigned flags)
 { return PL_get_list_nchars(l, NULL, s, flags);
@@ -1213,6 +1213,16 @@ nameOfWideAtom(atom_t atom)
   return RepAtom(a)->WStrOfAE;
 }
 
+access_level_t
+setAccessLevel(access_level_t accept)
+{ GET_LD
+  bool old;
+
+  old = LD->prolog_flag.access_level;
+  LD->prolog_flag.access_level = accept;
+  return old;
+}
+
 
 #if THREADS
 

H/pl-global.h

@@ -81,6 +81,15 @@ typedef struct {
     int		optimise;		/* -O: optimised compilation */
   } cmdline;
 
+  struct
+  { char *      CWDdir;
+    size_t      CWDlen;
+    char *      executable;             /* Running executable */
+#ifdef __WINDOWS__
+    char *      module;                 /* argv[0] module passed */
+#endif
+  } paths;
+
   struct
   { ExtensionCell _ext_head;		/* head of registered extensions */
     ExtensionCell _ext_tail;		/* tail of this chain */
@@ -193,6 +202,7 @@ typedef struct PL_local_data {
     pl_features_t mask;                 /* Masked access to booleans */
     int           write_attributes;     /* how to write attvars? */
     occurs_check_t occurs_check;        /* Unify and occurs check */
+    access_level_t access_level;        /* Current access level */
   } prolog_flag;
 
   void *        glob_info;              /* pl-glob.c */

H/pl-incl.h

@@ -240,6 +240,7 @@ users foreign language code.
 #define PRED_LD
 #define PASS_LD
 #define PASS_LD1 
+#define IGNORE_LD
 
 #else
 
@@ -253,6 +254,7 @@ users foreign language code.
 #define PASS_LD1  LD
 #define PASS_LD   , LD
 #define PRED_LD   GET_LD
+#define IGNORE_LD (void)__PL_ld;
 
 #endif
 
@@ -466,9 +468,6 @@ typedef struct
 #define FT_FROM_VALUE   0x0f            /* Determine type from value */
 #define FT_MASK         0x0f            /* mask to get type */
 
-#define FF_READONLY	0x10		/* feature is read-only */
-#define FF_KEEP		0x20		/* keep value it already set */
-
 #define PLFLAG_CHARESCAPE           0x000001 /* handle \ in atoms */
 #define PLFLAG_GC                   0x000002 /* do GC */
 #define PLFLAG_TRACE_GC             0x000004 /* verbose gc */
@@ -531,6 +530,15 @@ typedef struct redir_context
 
 #include "pl-file.h"
 
+typedef enum
+{ ACCESS_LEVEL_USER = 0,        /* Default user view */
+  ACCESS_LEVEL_SYSTEM           /* Allow low-level access */
+} access_level_t;
+
+#define SYSTEM_MODE         (LD->prolog_flag.access_level == ACCESS_LEVEL_SYSTEM)
+
+#define PL_malloc_atomic malloc
+
 /* vsc: global variables */
 #include "pl-global.h"
 
@@ -682,6 +690,7 @@ typedef double			real;
 
 #endif
 
+#define PL_unify_time(A,B) PL_unify_int64(A,B)
 extern int PL_unify_char(term_t chr, int c, int how);
 extern int PL_get_char(term_t chr, int *c, int eof);
 extern void PL_cleanup_fork(void);
@@ -691,6 +700,7 @@ extern int PL_unify_atomic(term_t t, PL_atomic_t a);
 extern int _PL_unify_atomic(term_t t, PL_atomic_t a);
 extern int _PL_unify_string(term_t t, word w);
 
+
 #define _PL_get_arg(X,Y,Z) PL_get_arg(X,Y,Z)
 
 extern IOSTREAM **			/* provide access to Suser_input, */
@@ -797,6 +807,7 @@ COMMON(int)		unicode_separator(pl_wchar_t c);
 COMMON(word) 		pl_raw_read(term_t term);
 COMMON(word) 		pl_raw_read2(term_t stream, term_t term);
 
+COMMON(access_level_t)	setAccessLevel(access_level_t new_level);
 
 /**** stuff from pl-error.c ****/
 extern void		outOfCore(void);
@@ -838,7 +849,7 @@ extern size_t getenv3(const char *name, char *buf, size_t len);
 extern int Setenv(char *name, char *value);
 extern int Unsetenv(char *name);
 extern int System(char *cmd);
-extern bool expandVars(const char *pattern, char *expanded, int maxlen);
+extern char *expandVars(const char *pattern, char *expanded, int maxlen);
 
 /**** SWI stuff (emulated in pl-yap.c) ****/
 extern int writeAtomToStream(IOSTREAM *so, atom_t at);
@@ -899,7 +910,7 @@ COMMON(Buffer)		codes_or_chars_to_buffer(term_t l, unsigned int flags,
 COMMON(bool)		systemMode(bool accept);
 
 
-COMMON(void)		initPrologFlagTable(void);
+COMMON(void)		cleanupPrologFlags(void);
 COMMON(void)		initPrologFlags(void);
 COMMON(int)		raiseStackOverflow(int overflow);
 

include/SWI-Prolog.h

@@ -622,7 +622,7 @@ extern char *PL_prompt_string(int fd);
 PL_EXPORT(int)          PL_get_file_name(term_t n, char **name, int flags);
 PL_EXPORT(int)          PL_get_file_nameW(term_t n, wchar_t **name, int flags);
 PL_EXPORT(void)         PL_changed_cwd(void); /* foreign code changed CWD */
-PL_EXPORT(const char *) PL_cwd(void);
+PL_EXPORT(char *)	PL_cwd(char *buf, size_t buflen);
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 NOTE: the functions in this section are   not  documented, as as yet not
@@ -788,8 +788,6 @@ PL_EXPORT(int)		PL_unify_mpq(term_t t, mpq_t mpz);
 
 #endif
 
-extern X_API  const char *PL_cwd(void);
-
 void swi_install(void);
 
 X_API int PL_warning(const char *msg, ...);

os/SWI-Stream.h

@@ -65,6 +65,10 @@ typedef intptr_t ssize_t;		/* signed version of size_t */
 extern "C" {
 #endif
 
+#ifndef PL_HAVE_TERM_T
+#define PL_HAVE_TERM_T
+typedef	uintptr_t    term_t;
+#endif
 		 /*******************************
 		 *	    CONSTANTS		*
 		 *******************************/
@@ -335,14 +339,10 @@ PL_EXPORT(int)		Sfpasteof(IOSTREAM *s);
 PL_EXPORT(int)		Sferror(IOSTREAM *s);
 PL_EXPORT(void)		Sclearerr(IOSTREAM *s);
 PL_EXPORT(void)		Sseterr(IOSTREAM *s, int which, const char *message);
-#ifdef _FLI_H_INCLUDED
 PL_EXPORT(void)		Sset_exception(IOSTREAM *s, term_t ex);
-#else
-PL_EXPORT(void)		Sset_exception(IOSTREAM *s, intptr_t ex);
-#endif
 PL_EXPORT(int)		Ssetenc(IOSTREAM *s, IOENC new_enc, IOENC *old_enc);
 PL_EXPORT(int)		Sflush(IOSTREAM *s);
-PL_EXPORT(long)		Ssize(IOSTREAM *s);
+PL_EXPORT(int64_t)		Ssize(IOSTREAM *s);
 PL_EXPORT(int)		Sseek(IOSTREAM *s, long pos, int whence);
 PL_EXPORT(long)		Stell(IOSTREAM *s);
 PL_EXPORT(int)		Sclose(IOSTREAM *s);

os/pl-ctype.c

@@ -471,7 +471,7 @@ init_tout(PL_chars_t *t, size_t len)
       { t->text.t = t->buf;
 	t->storage = PL_CHARS_LOCAL;
       } else
-      { t->text.t = PL_malloc(len+1);
+      { t->text.t = PL_malloc(len);
 	t->storage = PL_CHARS_MALLOC;
       }
       succeed;
@@ -480,7 +480,7 @@ init_tout(PL_chars_t *t, size_t len)
       { t->text.w = (pl_wchar_t*)t->buf;
 	t->storage = PL_CHARS_LOCAL;
       } else
-	{ t->text.w = PL_malloc((len+1)*sizeof(pl_wchar_t));
+      { t->text.w = PL_malloc(len*sizeof(pl_wchar_t));
 	t->storage = PL_CHARS_MALLOC;
       }
       succeed;

os/pl-file.c

@@ -1154,6 +1154,7 @@ protocol(const char *str, size_t n)
 		 *	  TEMPORARY I/O		*
 		 *******************************/
 
+
 int
 push_input_context(atom_t type)
 { GET_LD
@@ -1953,7 +1954,7 @@ error:
   return FALSE;
 }
 
-#if defined(__WINDOWS__) && !defined(__MINGW32__)	/* defined in pl-nt.c */
+#ifdef _MSC_VER					/* defined in pl-nt.c */
 extern int ftruncate(int fileno, int64_t length);
 #define HAVE_FTRUNCATE
 #endif
@@ -3586,8 +3587,10 @@ static int
 stream_file_name_propery(IOSTREAM *s, term_t prop ARG_LD)
 { atom_t name;
 
-  if ( (name = getStreamContext(s)->filename) )
+  for(; s; s=s->downstream)
-  { return PL_unify_atom(prop, name);
+  { if ( (name = getStreamContext(s)->filename) )
+    { return PL_unify_atom(prop, name);
+    }
   }
 
   return FALSE;
@@ -3617,13 +3620,17 @@ stream_mode_property(IOSTREAM *s, term_t prop ARG_LD)
 
 static int
 stream_input_prop(IOSTREAM *s ARG_LD)
-{ return (s->flags & SIO_INPUT) ? TRUE : FALSE;
+{ IGNORE_LD
+
+  return (s->flags & SIO_INPUT) ? TRUE : FALSE;
 }
 
 
 static int
 stream_output_prop(IOSTREAM *s ARG_LD)
-{ return (s->flags & SIO_OUTPUT) ? TRUE : FALSE;
+{ IGNORE_LD
+
+  return (s->flags & SIO_OUTPUT) ? TRUE : FALSE;
 }
 
 
@@ -3664,7 +3671,9 @@ stream_alias_prop(IOSTREAM *s, term_t prop ARG_LD)
 
 static int
 stream_position_prop(IOSTREAM *s, term_t prop ARG_LD)
-{ if ( s->position )
+{ IGNORE_LD
+
+  if ( s->position )
   { return PL_unify_term(prop,
 			 PL_FUNCTOR, FUNCTOR_stream_position4,
 			   PL_INT64, s->position->charno,
@@ -3680,8 +3689,7 @@ stream_position_prop(IOSTREAM *s, term_t prop ARG_LD)
 static int
 stream_end_of_stream_prop(IOSTREAM *s, term_t prop ARG_LD)
 { if ( s->flags & SIO_INPUT )
-  { GET_LD
+  { atom_t val;
-    atom_t val;
 
     if ( s->flags & SIO_FEOF2 )
       val = ATOM_past;
@@ -3730,7 +3738,7 @@ stream_reposition_prop(IOSTREAM *s, term_t prop ARG_LD)
     int fd = Sfileno(s);
     struct stat buf;
 
-    if ( fstat(fd, &buf) == 0 && S_ISREG(buf.st_mode) )
+    if ( fd != -1 && fstat(fd, &buf) == 0 && S_ISREG(buf.st_mode) )
       val = ATOM_true;
     else
       val = ATOM_false;
@@ -3746,7 +3754,9 @@ stream_reposition_prop(IOSTREAM *s, term_t prop ARG_LD)
 
 static int
 stream_close_on_abort_prop(IOSTREAM *s, term_t prop ARG_LD)
-{ return PL_unify_bool_ex(prop, !(s->flags & SIO_NOCLOSE));
+{ IGNORE_LD
+
+  return PL_unify_bool_ex(prop, !(s->flags & SIO_NOCLOSE));
 }
 
 
@@ -3769,7 +3779,9 @@ stream_file_no_prop(IOSTREAM *s, term_t prop ARG_LD)
 
 static int
 stream_tty_prop(IOSTREAM *s, term_t prop ARG_LD)
-{ if ( (s->flags & SIO_ISATTY) )
+{ IGNORE_LD
+
+  if ( (s->flags & SIO_ISATTY) )
     return PL_unify_bool_ex(prop, TRUE);
 
   return FALSE;
@@ -3778,7 +3790,9 @@ stream_tty_prop(IOSTREAM *s, term_t prop ARG_LD)
 
 static int
 stream_bom_prop(IOSTREAM *s, term_t prop ARG_LD)
-{ if ( (s->flags & SIO_BOM) )
+{ IGNORE_LD
+
+  if ( (s->flags & SIO_BOM) )
     return PL_unify_bool_ex(prop, TRUE);
 
   return FALSE;
@@ -3876,6 +3890,7 @@ stream_close_on_exec_prop(IOSTREAM *s, term_t prop ARG_LD)
 #else
    int fd_flags;
 #endif
+   IGNORE_LD
 
    if ( (fd = Sfileno(s)) < 0)
      return FALSE;
@@ -3915,7 +3930,7 @@ static const sprop sprop_list [] =
   { FUNCTOR_end_of_stream1, stream_end_of_stream_prop },
   { FUNCTOR_eof_action1,    stream_eof_action_prop },
   { FUNCTOR_reposition1,    stream_reposition_prop },
-  { FUNCTOR_type1,    	    stream_type_prop },
+  { FUNCTOR_type1,	    stream_type_prop },
   { FUNCTOR_file_no1,	    stream_file_no_prop },
   { FUNCTOR_buffer1,	    stream_buffer_prop },
   { FUNCTOR_buffer_size1,   stream_buffer_size_prop },
@@ -3974,7 +3989,7 @@ PRED_IMPL("stream_property", 2, stream_property,
 			    ATOM_stream_property, property);
 	}
 
-	pe = allocHeap(sizeof(*pe));
+	pe = allocForeignState(sizeof(*pe));
 
 	pe->e = newTableEnum(streamContext);
 	pe->s = NULL;
@@ -3992,7 +4007,7 @@ PRED_IMPL("stream_property", 2, stream_property,
       { functor_t f;
 
 	if ( PL_is_variable(property) )	/* generate properties */
-	{ pe = allocHeap(sizeof(*pe));
+	{ pe = allocForeignState(sizeof(*pe));
 
 	  pe->e = NULL;
 	  pe->s = s;
@@ -4050,7 +4065,7 @@ PRED_IMPL("stream_property", 2, stream_property,
       { if ( pe->e )
 	  freeTableEnum(pe->e);
 
-	freeHeap(pe, sizeof(*pe));
+	freeForeignState(pe, sizeof(*pe));
       }
       return TRUE;
     }
@@ -4066,7 +4081,7 @@ PRED_IMPL("stream_property", 2, stream_property,
     if ( pe->e )
       freeTableEnum(pe->e);
 
-    freeHeap(pe, sizeof(*pe));
+    freeForeignState(pe, sizeof(*pe));
     return FALSE;
   }
 
@@ -4140,7 +4155,7 @@ PRED_IMPL("stream_property", 2, stream_property,
     { if ( pe->e )
 	freeTableEnum(pe->e);
 
-      freeHeap(pe, sizeof(*pe));
+      freeForeignState(pe, sizeof(*pe));
       return FALSE;
     }
   }
@@ -4385,7 +4400,8 @@ PRED_IMPL("current_output", 1, current_output, PL_FA_ISO)
 
 static
 PRED_IMPL("byte_count", 2, byte_count, 0)
-{ IOSTREAM *s;
+{ PRED_LD
+  IOSTREAM *s;
 
   if ( getStreamWithPosition(A1, &s) )
   { int64_t n = s->position->byteno;
@@ -4400,7 +4416,8 @@ PRED_IMPL("byte_count", 2, byte_count, 0)
 
 static
 PRED_IMPL("character_count", 2, character_count, 0)
-{ IOSTREAM *s;
+{ PRED_LD
+  IOSTREAM *s;
 
   if ( getStreamWithPosition(A1, &s) )
   { int64_t n = s->position->charno;
@@ -4501,7 +4518,7 @@ peek(term_t stream, term_t chr, int how ARG_LD)
 
   if ( !getInputStream(stream, how == PL_BYTE ? S_BINARY : S_TEXT, &s) )
     return FALSE;
-  if ( true(s, SIO_NBUF) || (s->bufsize && s->bufsize < MB_LEN_MAX) )
+  if ( true(s, SIO_NBUF) || (s->bufsize && s->bufsize < PL_MB_LEN_MAX) )
   { releaseStream(s);
     return PL_error(NULL, 0, "stream is unbuffered", ERR_PERMISSION,
 		    ATOM_peek, ATOM_stream, stream);
@@ -4588,20 +4605,23 @@ ssize_t
 Sread_user(void *handle, char *buf, size_t size)
 { GET_LD
   wrappedIO *wio = handle;
+  ssize_t rc;
 
   if ( LD->prompt.next && ttymode != TTY_RAW )
     PL_write_prompt(TRUE);
   else
     Sflush(Suser_output);
 
-  size = (*wio->wrapped_functions->read)(wio->wrapped_handle, buf, size);
+  rc = (*wio->wrapped_functions->read)(wio->wrapped_handle, buf, size);
-  if ( size == 0 )			/* end-of-file */
+  if ( rc == 0 )			/* end-of-file */
   { Sclearerr(Suser_input);
     LD->prompt.next = TRUE;
-  } else if ( size > 0 && buf[size-1] == '\n' )
+  } else if ( rc == 1 && buf[0] == 04 )
+  { rc = 0;				/* Map ^D to end-of-file */
+  } else if ( rc > 0 && buf[rc-1] == '\n' )
     LD->prompt.next = TRUE;
 
-  return size;
+  return rc;
 }
 
 
@@ -4649,9 +4669,9 @@ PRED_IMPL("set_prolog_IO", 3, set_prolog_IO, 0)
   IOSTREAM *in = NULL, *out = NULL, *error = NULL;
   int rval = FALSE;
   int wrapin = FALSE;
+  int i;
 
-  if ( !term_stream_handle(A1, &in, SH_ERRORS|SH_ALIAS|SH_UNLOCKED PASS_LD) ||
+  if ( !term_stream_handle(A1, &in, SH_ERRORS|SH_ALIAS|SH_UNLOCKED PASS_LD) )
-       !term_stream_handle(A2, &out, SH_ERRORS|SH_ALIAS PASS_LD) )
     goto out;
 
   wrapin = (LD->IO.streams[0] != in);
@@ -4660,6 +4680,9 @@ PRED_IMPL("set_prolog_IO", 3, set_prolog_IO, 0)
       goto out;
   }
 
+  if ( !term_stream_handle(A2, &out, SH_ERRORS|SH_ALIAS PASS_LD) )
+    goto out;
+
   if ( PL_compare(A2, A3) == 0 )	/* == */
   { error = getStream(Snew(out->handle, out->flags, out->functions));
     if ( !error )
@@ -4686,6 +4709,11 @@ PRED_IMPL("set_prolog_IO", 3, set_prolog_IO, 0)
     LD->prompt.next = TRUE;
   }
 
+  for(i=0; i<3; i++)
+  { LD->IO.streams[i]->position = &LD->IO.streams[0]->posbuf;
+    LD->IO.streams[i]->flags |= SIO_RECORDPOS;
+  }
+
   UNLOCK();
   rval = TRUE;
 
@@ -4710,7 +4738,7 @@ PRED_IMPL("$size_stream", 2, size_stream, 0)
   if ( !PL_get_stream_handle(A1, &s) )
     return FALSE;
 
-  rval = PL_unify_integer(A2, Ssize(s));
+  rval = PL_unify_int64(A2, Ssize(s));
   PL_release_stream(s);
 
   return rval;
@@ -4855,15 +4883,12 @@ BeginPredDefs(file)
   PRED_DEF("is_stream", 1, is_stream, 0)
   PRED_DEF("set_stream", 2, set_stream, 0)
   PRED_DEF("with_output_to", 2, with_output_to, PL_FA_TRANSPARENT)
-//vsc
   PRED_DEF("set_prolog_IO", 3, set_prolog_IO, 0)
   PRED_DEF("protocol", 1, protocol, 0)
   PRED_DEF("protocola", 1, protocola, 0)
   PRED_DEF("noprotocol", 0, noprotocol, 0)
   PRED_DEF("protocolling", 1, protocolling, 0)
-//vsc
   PRED_DEF("prompt1", 1, prompt1, 0)
-//vsc
   PRED_DEF("seek", 4, seek, 0)
   PRED_DEF("wait_for_input", 3, wait_for_input, 0)
   PRED_DEF("get_single_char", 1, get_single_char, 0)
@@ -4875,11 +4900,10 @@ BeginPredDefs(file)
   PRED_DEF("set_end_of_stream", 1, set_end_of_stream, 0)
 
 					/* SWI internal */
-  PRED_DEF("$push_input_context", 0, push_input_context, 0)
+  PRED_DEF("$push_input_context", 1, push_input_context, 0)
   PRED_DEF("$pop_input_context", 0, pop_input_context, 0)
   PRED_DEF("$input_context", 1, input_context, 0)
   PRED_DEF("$size_stream", 2, size_stream, 0)
-//vsc
 EndPredDefs
 
 #if __YAP_PROLOG__

os/pl-files.c

@@ -3,9 +3,10 @@
     Part of SWI-Prolog
 
     Author:        Jan Wielemaker
-    E-mail:        J.Wielemaker@uva.nl
+    E-mail:        J.Wielemaker@cs.vu.nl
     WWW:           http://www.swi-prolog.org
-    Copyright (C): 1985-2008, University of Amsterdam
+    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
@@ -19,7 +20,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 #include "pl-incl.h"
@@ -44,26 +45,89 @@
 General file operations and binding to Prolog
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
+#ifdef __WINDOWS__
+static void
+set_posix_error(int win_error)
+{ int error = 0;
+
+  switch(win_error)
+  { case ERROR_ACCESS_DENIED:	  error = EACCES; break;
+    case ERROR_FILE_NOT_FOUND:    error = ENOENT; break;
+    case ERROR_SHARING_VIOLATION: error = EAGAIN; break;
+    case ERROR_ALREADY_EXISTS:    error = EEXIST; break;
+  }
+
+  errno = error;
+}
+#endif /*__WINDOWS__*/
+
+
 		 /*******************************
 		 *	      OS STUFF		*
 		 *******************************/
 
-/** time_t LastModifiedFile(const char *file)
+/** int LastModifiedFile(const char *file, double *t)
 
 Return the last modification time of file  as a POSIX timestamp. Returns
 (time_t)-1 on failure.
+
+Contains a 64-bit value representing the number of 100-nanosecond
+intervals since January 1, 1601 (UTC).
 */
 
+int
+LastModifiedFile(const char *name, double *tp)
+{
+#ifdef __WINDOWS__
+  HANDLE hFile;
+  wchar_t wfile[MAXPATHLEN];
 
-time_t
+#define nano * 0.000000001
-LastModifiedFile(const char *file)
+#define ntick 100.0
-{ char tmp[MAXPATHLEN];
+#define SEC_TO_UNIX_EPOCH 11644473600.0
+
+  if ( !_xos_os_filenameW(name, wfile, MAXPATHLEN) )
+    return FALSE;
+
+  if ( (hFile=CreateFileW(wfile,
+			  0,
+			  FILE_SHARE_DELETE|FILE_SHARE_READ|FILE_SHARE_WRITE,
+			  NULL,
+			  OPEN_EXISTING,
+			  FILE_FLAG_BACKUP_SEMANTICS,
+			  NULL)) != INVALID_HANDLE_VALUE )
+  { FILETIME wt;
+    int rc;
+
+    rc = GetFileTime(hFile, NULL, NULL, &wt);
+    CloseHandle(hFile);
+
+    if ( rc )
+    { double t;
+
+      t  = (double)wt.dwHighDateTime * (4294967296.0 * ntick nano);
+      t += (double)wt.dwLowDateTime  * (ntick nano);
+      t -= SEC_TO_UNIX_EPOCH;
+
+      *tp = t;
+
+      return TRUE;
+    }
+  }
+
+  set_posix_error(GetLastError());
+
+  return FALSE;
+#else
+  char tmp[MAXPATHLEN];
   statstruct buf;
 
-  if ( statfunc(OsPath(file, tmp), &buf) < 0 )
+  if ( statfunc(OsPath(name, tmp), &buf) < 0 )
-    return (time_t)-1;
+    return FALSE;
 
-  return buf.st_mtime;
+  *tp = (double)buf.st_mtime;
+  return TRUE;
+#endif
 }
 
 
@@ -349,13 +413,7 @@ MarkExecutable(const char *name)
 
 int
 unifyTime(term_t t, time_t time)
-{ 
+{ return PL_unify_time(t, time);
-#if __YAP_PROLOG__
-  /* maintain compatibility with old Prolog systems, and avoid losing precision unnecessarily */
-  return PL_unify_int64(t, (int64_t)time);
-#else
-  return PL_unify_float(t, (double)time);
-#endif
 }
 
 
@@ -433,9 +491,12 @@ get_file_name(term_t n, char **namep, char *tmp, int flags)
     return PL_error(NULL, 0, "file name contains a 0-code",
 		    ERR_DOMAIN, ATOM_file_name, n);
   }
+  if ( len+1 >= MAXPATHLEN )
+    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
+		    ATOM_max_path_length);
 
   if ( truePrologFlag(PLFLAG_FILEVARS) )
-  { if ( !(name = ExpandOneFile(name, tmp)) )
+  { if ( !(name = expandVars(name, tmp, MAXPATHLEN)) )
       return FALSE;
   }
 
@@ -529,13 +590,13 @@ PRED_IMPL("time_file", 2, time_file, 0)
 { char *fn;
 
   if ( PL_get_file_name(A1, &fn, 0) )
-  { time_t time;
+  { double time;
 
-    if ( (time = LastModifiedFile(fn)) == (time_t)-1 )
+    if ( LastModifiedFile(fn, &time) )
-      return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION,
+      return PL_unify_float(A2, time);
-		      ATOM_time, ATOM_file, A1);
 
-    return unifyTime(A2, time);
+    return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION,
+		    ATOM_time, ATOM_file, A1);
   }
 
   return FALSE;
@@ -544,7 +605,8 @@ PRED_IMPL("time_file", 2, time_file, 0)
 
 static
 PRED_IMPL("size_file", 2, size_file, 0)
-{ char *n;
+{ PRED_LD
+  char *n;
 
   if ( PL_get_file_name(A1, &n, 0) )
   { int64_t size;
@@ -680,7 +742,7 @@ static
 PRED_IMPL("file_base_name", 2, file_base_name, 0)
 { char *n;
 
-  if ( !PL_get_chars_ex(A1, &n, CVT_ALL|REP_FN) )
+  if ( !PL_get_chars(A1, &n, CVT_ALL|REP_FN|CVT_EXCEPTION) )
     return FALSE;
 
   return PL_unify_chars(A2, PL_ATOM|REP_FN, -1, BaseName(n));
@@ -692,7 +754,7 @@ PRED_IMPL("file_directory_name", 2, file_directory_name, 0)
 { char *n;
   char tmp[MAXPATHLEN];
 
-  if ( !PL_get_chars_ex(A1, &n, CVT_ALL|REP_FN) )
+  if ( !PL_get_chars(A1, &n, CVT_ALL|REP_FN|CVT_EXCEPTION) )
     return FALSE;
 
   return PL_unify_chars(A2, PL_ATOM|REP_FN, -1, DirName(n, tmp));
@@ -868,12 +930,13 @@ PRED_IMPL("$absolute_file_name", 2, absolute_file_name, 0)
 static
 PRED_IMPL("working_directory", 2, working_directory, 0)
 { PRED_LD
+  char buf[MAXPATHLEN];
   const char *wd;
 
   term_t old = A1;
   term_t new = A2;
 
-  if ( !(wd = PL_cwd()) )
+  if ( !(wd = PL_cwd(buf, sizeof(buf))) )
     return FALSE;
 
   if ( PL_unify_chars(old, PL_ATOM|REP_FN, -1, wd) )
@@ -966,8 +1029,8 @@ PRED_IMPL("file_name_extension", 3, file_name_extension, 0)
     PL_fail;
   }
 
-  if ( PL_get_chars_ex(base, &b, CVT_ALL|BUF_RING|REP_FN) &&
+  if ( PL_get_chars(base, &b, CVT_ALL|BUF_RING|REP_FN|CVT_EXCEPTION) &&
-       PL_get_chars_ex(ext, &e, CVT_ALL|REP_FN) )
+       PL_get_chars(ext, &e, CVT_ALL|REP_FN|CVT_EXCEPTION) )
   { char *s;
 
     if ( e[0] == '.' )		/* +Base, +Extension, -full */
@@ -989,20 +1052,19 @@ PRED_IMPL("file_name_extension", 3, file_name_extension, 0)
 
 static
 PRED_IMPL("prolog_to_os_filename", 2, prolog_to_os_filename, 0)
-{
+{ PRED_LD
 
   term_t pl = A1;
   term_t os = A2;
 
 #ifdef O_XOS
-  PRED_LD
   wchar_t *wn;
 
   if ( !PL_is_variable(pl) )
   { char *n;
     wchar_t buf[MAXPATHLEN];
 
-    if ( PL_get_chars_ex(pl, &n, CVT_ALL|REP_UTF8) )
+    if ( PL_get_chars(pl, &n, CVT_ALL|REP_UTF8|CVT_EXCEPTION) )
     { if ( !_xos_os_filenameW(n, buf, MAXPATHLEN) )
 	return name_too_long();
 

os/pl-files.h

@@ -19,7 +19,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 #ifndef PL_FILES_H_INCLUDED
@@ -31,11 +31,11 @@
 #define ACCESS_WRITE	4
 
 COMMON(void)		initFiles(void);
-COMMON(time_t)	 	LastModifiedFile(const char *f);
+COMMON(int)		LastModifiedFile(const char *f, double *t);
-COMMON(int) 		RemoveFile(const char *path);
+COMMON(int)		RemoveFile(const char *path);
 COMMON(int)		AccessFile(const char *path, int mode);
-COMMON(char *) 		DeRefLink(const char *link, char *buf);
+COMMON(char *)		DeRefLink(const char *link, char *buf);
-COMMON(int) 		ExistsFile(const char *path);
+COMMON(int)		ExistsFile(const char *path);
-COMMON(int) 		ExistsDirectory(const char *path);
+COMMON(int)		ExistsDirectory(const char *path);
 
 #endif /*PL_FILES_H_INCLUDED*/

os/pl-fmt.c

@@ -19,7 +19,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -53,9 +53,9 @@ typedef struct
   struct rubber rub[MAXRUBBER];
 } format_state;
 
-#define BUFSIZE 	1024
+#define BUFSIZE		1024
-#define DEFAULT 	(-1)
+#define DEFAULT		(-1)
-#define SHIFT   	{ argc--; argv++; }
+#define SHIFT		{ argc--; argv++; }
 #define NEED_ARG	{ if ( argc <= 0 ) \
 			  { FMT_ERROR("not enough arguments"); \
 			  } \
@@ -189,7 +189,8 @@ outtext(format_state *state, PL_chars_t *txt)
 #define format_predicates (GD->format.predicates)
 
 static int	update_column(int, Char);
-static bool	do_format(IOSTREAM *fd, PL_chars_t *fmt, int ac, term_t av);
+static bool	do_format(IOSTREAM *fd, PL_chars_t *fmt,
+			  int ac, term_t av, Module m);
 static void	distribute_rubber(struct rubber *, int, int);
 static int	emit_rubber(format_state *state);
 
@@ -272,7 +273,7 @@ pl_current_format_predicate(term_t chr, term_t descr, control_t h)
 
 
 static word
-format_impl(IOSTREAM *out, term_t format, term_t Args)
+format_impl(IOSTREAM *out, term_t format, term_t Args, Module m)
 { GET_LD
   term_t argv;
   int argc = 0;
@@ -307,7 +308,7 @@ format_impl(IOSTREAM *out, term_t format, term_t Args)
       break;
   }
 
-  rval = do_format(out, &fmt, argc, argv);
+  rval = do_format(out, &fmt, argc, argv, m);
   PL_free_text(&fmt);
   if ( !endCritical )
     return FALSE;
@@ -318,31 +319,20 @@ format_impl(IOSTREAM *out, term_t format, term_t Args)
 
 word
 pl_format3(term_t out, term_t format, term_t args)
-{ redir_context ctx;
+{ GET_LD
+  redir_context ctx;
   word rc;
-#if __YAP_PROLOG__
+  Module m = NULL;
-  /*
+  term_t list = PL_new_term_ref();
-    YAP allows the last argument to format to be of the form
-    module:[]
-  */
-  YAP_Term mod;
-#endif    
 
-  if ( (rc=setupOutputRedirect(out, &ctx, FALSE)) ) {
+  if ( !PL_strip_module(args, &m, list) )
-#if __YAP_PROLOG__
+    return FALSE;
-    /* module processing */
+
-    {
+  if ( (rc=setupOutputRedirect(out, &ctx, FALSE)) )
-      args = Yap_fetch_module_for_format(args, &mod);
+  { if ( (rc = format_impl(ctx.stream, format, list, m)) )
-    }
+      rc = closeOutputRedirect(&ctx);
-#endif    
+    else
-    { if ( (rc = format_impl(ctx.stream, format, args)) )
-	rc = closeOutputRedirect(&ctx);
-      else
       discardOutputRedirect(&ctx);
-    }
-#if __YAP_PROLOG__
-    YAP_SetCurrentModule(mod);
-#endif    
   }
 
   return rc;
@@ -374,7 +364,7 @@ get_chr_from_text(const PL_chars_t *t, int index)
 		********************************/
 
 static bool
-do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
+do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
 { GET_LD
   format_state state;			/* complete state */
   int tab_stop = 0;			/* padded tab stop */
@@ -443,7 +433,7 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 	    char buf[BUFSIZE];
 	    char *str = buf;
 	    size_t bufsize = BUFSIZE;
-	    unsigned int i;
+	    int i;
 
 	    PL_predicate_info(proc, NULL, &arity, NULL);
 	    av = PL_new_term_refs(arity);
@@ -481,7 +471,9 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 		  if ( !PL_get_text(argv, &txt, CVT_ATOMIC) )
 		    FMT_ARG("a", argv);
 		  SHIFT;
-		  outtext(&state, &txt);
+		  rc = outtext(&state, &txt);
+                  if ( !rc )
+		    goto out;
 		  here++;
 		  break;
 		}
@@ -494,7 +486,9 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 
 		    SHIFT;
 		    while(times-- > 0)
-		    { outchr(&state, chr);
+		    { rc = outchr(&state, chr);
+		      if ( !rc )
+		        goto out;
 		    }
 		  } else
 		    FMT_ARG("c", argv);
@@ -508,7 +502,7 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 	      case 'G':			/* shortest of 'f' and 'E' */
 		{ number n;
 		  union {
-		    tmp_buffer b;
+		  tmp_buffer b;
 		    buffer b1;
 		  } u;
 
@@ -525,8 +519,10 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 		  initBuffer(&u.b);
 		  formatFloat(c, arg, &n, &u.b1);
 		  clearNumber(&n);
-		  outstring0(&state, baseBuffer(&u.b, char));
+		  rc = outstring0(&state, baseBuffer(&u.b, char));
 		  discardBuffer(&u.b);
+                  if ( !rc )
+		    goto out;
 		  here++;
 		  break;
 		}
@@ -564,8 +560,10 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 		    formatNumber(FALSE, 0, arg, c == 'r', &i, (Buffer)&b);
 		  }
 		  clearNumber(&i);
-		  outstring0(&state, baseBuffer(&b, char));
+		  rc = outstring0(&state, baseBuffer(&b, char));
 		  discardBuffer(&b);
+		  if ( !rc )
+		    goto out;
 		  here++;
 		  break;
 		}
@@ -576,8 +574,10 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 		  if ( !PL_get_text(argv, &txt, CVT_LIST|CVT_STRING) &&
 		       !PL_get_text(argv, &txt, CVT_ATOM) ) /* SICStus compat */
 		    FMT_ARG("s", argv);
-		  outtext(&state, &txt);
+		  rc = outtext(&state, &txt);
 		  SHIFT;
+		  if ( !rc )
+		    goto out;
 		  here++;
 		  break;
 		}
@@ -610,8 +610,10 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 
 		    str = buf;
 		    tellString(&str, &bufsize, ENC_UTF8);
-		    (*f)(argv);
+		    rc = (*f)(argv);
 		    toldString();
+		    if ( !rc )
+		      goto out;
 		    oututf8(&state, str, bufsize);
 		    if ( str != buf )
 		      free(str);
@@ -632,8 +634,10 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 
 		      str = buf;
 		      tellString(&str, &bufsize, ENC_UTF8);
-		      (*f)(argv);
+		      rc = (*f)(argv);
 		      toldString();
+		      if ( !rc )
+		        goto out;
 		      oututf8(&state, str, bufsize);
 		      if ( str != buf )
 			free(str);
@@ -704,7 +708,7 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 		  { FMT_ERROR("not enough arguments");
 		  }
 		  tellString(&str, &bufsize, ENC_UTF8);
-		  rval = callProlog(NULL, argv, PL_Q_CATCH_EXCEPTION, &ex);
+		  rval = callProlog(m, argv, PL_Q_CATCH_EXCEPTION, &ex);
 		  toldString();
 		  oututf8(&state, str, bufsize);
 		  if ( str != buf )
@@ -724,7 +728,9 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 		  break;
 	        }
 	      case '~':			/* ~ */
-		{ outchr(&state, '~');
+		{ rc = outchr(&state, '~');
+		  if ( !rc )
+		    goto out;
 		  here++;
 		  break;
 		}
@@ -735,7 +741,10 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 		  if ( c == 'N' && state.column == 0 )
 		    arg--;
 		  while( arg-- > 0 )
-		    outchr(&state, '\n');
+                  { rc = outchr(&state, '\n');
+		    if ( !rc )
+		      goto out;
+                  }
 		  here++;
 		  break;
 		}
@@ -790,7 +799,9 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv)
 	  break;			/* the '~' switch */
 	}
       default:
-	{ outchr(&state, c);
+	{ rc = outchr(&state, c);
+	  if ( !rc )
+	    goto out;
 	  here++;
 	  break;
 	}
@@ -1032,7 +1043,8 @@ formatFloat(int how, int arg, Number f, Buffer out)
       while(written >= size)
       { size = written+1;
 
-	growBuffer(out, size);		/* reserve for -.e<null> */
+	if ( !growBuffer(out, size) )	/* reserve for -.e<null> */
+	  outOfCore();
 	written = gmp_snprintf(baseBuffer(out, char), size, tmp, mpf);
       }
       mpf_clear(mpf);
@@ -1053,7 +1065,8 @@ formatFloat(int how, int arg, Number f, Buffer out)
       while(written >= size)
       { size = written+1;
 
-	growBuffer(out, size);
+	if ( !growBuffer(out, size) )
+	  outOfCore();
 	written = snprintf(baseBuffer(out, char), size, tmp, f->value.f);
       }
       out->top = out->base + written;

os/pl-glob.c

@@ -3,9 +3,10 @@
     Part of SWI-Prolog
 
     Author:        Jan Wielemaker
-    E-mail:        jan@swi.psy.uva.nl
+    E-mail:        J.Wielemaker@cs.vu.nl
     WWW:           http://www.swi-prolog.org
-    Copyright (C): 1985-2002, University of Amsterdam
+    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
@@ -19,7 +20,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 #include "pl-incl.h"
@@ -29,9 +30,9 @@
 #include <unistd.h>
 #endif
 
-#ifdef __WATCOMC__
+#ifdef O_XOS
-#include <direct.h>
+# include "windows/dirent.h"
-#else /*__WATCOMC__*/
+#else
 #if HAVE_DIRENT_H
 # include <dirent.h>
 #else
@@ -46,7 +47,7 @@
 #  include <ndir.h>
 # endif
 #endif
-#endif /*__WATCOMC__*/
+#endif /*O_XOS*/
 
 #ifdef HAVE_SYS_STAT_H
 #include <sys/stat.h>
@@ -326,8 +327,8 @@ PRED_IMPL("wildcard_match", 2, wildcard_match, 0)
 { char *p, *s;
   compiled_pattern buf;
 
-  if ( !PL_get_chars_ex(A1, &p, CVT_ALL) ||
+  if ( !PL_get_chars(A1, &p, CVT_ALL|CVT_EXCEPTION) ||
-       !PL_get_chars_ex(A2,  &s, CVT_ALL) )
+       !PL_get_chars(A2,  &s, CVT_ALL|CVT_EXCEPTION) )
     fail;
 
   if ( compilePattern(p, &buf) )
@@ -423,6 +424,7 @@ expand(const char *pattern, GlobInfo info)
   compiled_pattern cbuf;
   char prefix[MAXPATHLEN];		/* before first pattern */
   char patbuf[MAXPATHLEN];		/* pattern buffer */
+  size_t prefix_len;
   int end, dot;
 
   initBuffer(&info->files);
@@ -441,20 +443,25 @@ expand(const char *pattern, GlobInfo info)
       switch( (c=*s++) )
       { case EOS:
 	  if ( s > pat )		/* something left and expanded */
-	  { un_escape(prefix, pat, s);
+	  { 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];
-	      size_t plen;
+	      const char *entry = expand_entry(info, info->start);
+	      size_t plen = strlen(entry);
 
-	      strcpy(path, expand_entry(info, info->start));
+	      if ( plen+prefix_len+2 <= MAXPATHLEN )
-	      plen = strlen(path);
+	      { strcpy(path, entry);
-	      if ( prefix[0] && plen > 0 && path[plen-1] != '/' )
+		if ( prefix[0] && plen > 0 && path[plen-1] != '/' )
-		path[plen++] = '/';
+		  path[plen++] = '/';
-	      strcpy(&path[plen], prefix);
+		strcpy(&path[plen], prefix);
-	      if ( end == 1 || AccessFile(path, ACCESS_EXIST) )
+		if ( end == 1 || AccessFile(path, ACCESS_EXIST) )
-		add_path(path, info);
+		  add_path(path, info);
+	      }
 	    }
 	  }
 	  succeed;
@@ -489,8 +496,9 @@ expand(const char *pattern, GlobInfo info)
 */
     un_escape(prefix, pat, head);
     un_escape(patbuf, head, tail);
+    prefix_len = strlen(prefix);
 
-    if ( !compilePattern(patbuf, &cbuf) )		/* syntax error */
+    if ( !compilePattern(patbuf, &cbuf) )	/* syntax error */
       fail;
     dot = (patbuf[0] == '.');			/* do dots as well */
 
@@ -502,6 +510,10 @@ expand(const char *pattern, GlobInfo info)
       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);
       strcat(path, prefix);
@@ -521,12 +533,11 @@ expand(const char *pattern, GlobInfo info)
 	       matchPattern(e->d_name, &cbuf) )
 	  { char newp[MAXPATHLEN];
 
-	    strcpy(newp, path);
+	    if ( plen+strlen(e->d_name)+1 < sizeof(newp) )
-	    strcpy(&newp[plen], e->d_name);
+	    { strcpy(newp, path);
-/*	    if ( !tail[0] || ExistsDirectory(newp) )
+	      strcpy(&newp[plen], e->d_name);
-	    Saves memory, but involves one more file-access
-*/
 	      add_path(newp, info);
+	    }
 	  }
 	}
 	closedir(d);
@@ -579,11 +590,11 @@ PRED_IMPL("expand_file_name", 2, expand_file_name, 0)
   term_t head = PL_new_term_ref();
   int i;
 
-  if ( !PL_get_chars_ex(A1, &s, CVT_ALL|REP_FN) )
+  if ( !PL_get_chars(A1, &s, CVT_ALL|REP_FN|CVT_EXCEPTION) )
     fail;
   if ( strlen(s) > sizeof(spec)-1 )
-    return PL_error(NULL, 0, "File name too intptr_t",
+    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
-		    ERR_DOMAIN, ATOM_pattern, A1);
+		    ATOM_max_path_length);
 
   if ( !expandVars(s, spec, sizeof(spec)) )
     fail;

os/pl-os.c

@@ -1,11 +1,10 @@
-/*  $Id$
+/*  Part of SWI-Prolog
-
-    Part of SWI-Prolog
 
     Author:        Jan Wielemaker
-    E-mail:        wielemak@science.uva.nl
+    E-mail:        J.Wielemaker@vu.nl
     WWW:           http://www.swi-prolog.org
-    Copyright (C): 1985-2007, University of Amsterdam
+    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
@@ -19,7 +18,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 /*  Modified (M) 1993 Dave Sherratt  */
@@ -30,6 +29,17 @@
 #include <os2.h>                /* this has to appear before pl-incl.h */
 #endif
 
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+Solaris has asctime_r() with 3 arguments. Using _POSIX_PTHREAD_SEMANTICS
+is supposed to give the POSIX standard one.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#if defined(__sun__) || defined(__sun)
+#define _POSIX_PTHREAD_SEMANTICS 1
+#endif
+
+#define __MINGW_USE_VC2005_COMPAT		/* Get Windows time_t as 64-bit */
+
 #include "pl-incl.h"
 #include "pl-ctype.h"
 #include "pl-utf8.h"
@@ -96,27 +106,11 @@ static double initial_time;
 static void	initExpand(void);
 static void	cleanupExpand(void);
 static void	initEnviron(void);
-static char *	Which(const char *program, char *fullname);
 
 #ifndef DEFAULT_PATH
 #define DEFAULT_PATH "/bin:/usr/bin"
 #endif
 
-		 /*******************************
-		 *	       GLOBALS		*
-		 *******************************/
-#ifdef HAVE_CLOCK
-long clock_wait_ticks;
-#endif
-
-/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-This module is a contraction of functions that used to be all  over  the
-place.   together  with  pl-os.h  (included  by  pl-incl.h) this file
-should define a basic  layer  around  the  OS,  on  which  the  rest  of
-SWI-Prolog  is  based.
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-
-
 		/********************************
 		*         INITIALISATION        *
 		*********************************/
@@ -145,20 +139,6 @@ initOs(void)
   setPrologFlagMask(PLFLAG_FILE_CASE_PRESERVING);
 #endif
 
-#ifdef HAVE_CLOCK
-  clock_wait_ticks = 0L;
-#endif
-
-#if OS2
-  { DATETIME i;
-    DosGetDateTime((PDATETIME)&i);
-    initial_time = (i.hours * 3600.0)
-                   + (i.minutes * 60.0)
-		   + i.seconds
-		   + (i.hundredths / 100.0);
-  }
-#endif /* OS2 */
-
   DEBUG(1, Sdprintf("OS:done\n"));
 
   succeed;
@@ -239,11 +219,26 @@ static char errmsg[64];
 #endif /*_SC_CLK_TCK*/
 #endif /*HAVE_TIMES*/
 
+#ifdef HAVE_CLOCK_GETTIME
+#define timespec_to_double(ts) \
+	((double)(ts).tv_sec + (double)(ts).tv_nsec/(double)1000000000.0)
+#endif
 
 double
 CpuTime(cputime_kind which)
 {
-#ifdef HAVE_TIMES
+#if defined(HAVE_CLOCK_GETTIME) && defined(CLOCK_PROCESS_CPUTIME_ID)
+#define CPU_TIME_DONE
+  struct timespec ts;
+  (void)which;
+
+  if ( clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts) == 0 )
+    return timespec_to_double(ts);
+  return 0.0;
+#endif
+
+#if !defined(CPU_TIME_DONE) && defined(HAVE_TIMES)
+#define CPU_TIME_DONE
   struct tms t;
   double used;
   static int MTOK_got_hz = FALSE;
@@ -268,39 +263,17 @@ CpuTime(cputime_kind which)
     used = 0.0;				/* happens when running under GDB */
 
   return used;
-#else
+#endif
 
-#if OS2 && EMX
+#if !defined(CPU_TIME_DONE)
-  DATETIME i;
+  (void)which;
-
-  DosGetDateTime((PDATETIME)&i);
-  return (((i.hours * 3600)
-                 + (i.minutes * 60)
-		 + i.seconds
-	         + (i.hundredths / 100.0)) - initial_time);
-#else
-
-#ifdef HAVE_CLOCK
-  return (double) (clock() - clock_wait_ticks) / (double) CLOCKS_PER_SEC;
-#else
 
   return 0.0;
-
-#endif
-#endif
 #endif
 }
 
 #endif /*__WINDOWS__*/
 
-void
-PL_clock_wait_ticks(long waited)
-{
-#ifdef HAVE_CLOCK
-  clock_wait_ticks += waited;
-#endif
-}
-
 
 double
 WallTime(void)
@@ -310,7 +283,7 @@ WallTime(void)
   struct timespec tp;
 
   clock_gettime(CLOCK_REALTIME, &tp);
-  stime = (double)tp.tv_sec + (double)tp.tv_nsec/1000000000.0;
+  stime = timespec_to_double(tp);
 #else
 #ifdef HAVE_GETTIMEOFDAY
   struct timeval tp;
@@ -389,7 +362,7 @@ CpuCount()
 #include <sys/sysctl.h>
 
 int
-CpuCount()
+CpuCount(void)
 { int     count ;
   size_t  size=sizeof(count) ;
 
@@ -415,7 +388,7 @@ setOSPrologFlags(void)
 { int cpu_count = CpuCount();
 
   if ( cpu_count > 0 )
-    PL_set_prolog_flag("cpu_count", PL_INTEGER|FF_READONLY, cpu_count);
+    PL_set_prolog_flag("cpu_count", PL_INTEGER, cpu_count);
 }
 #endif
 
@@ -436,8 +409,7 @@ UsedMemory(void)
   }
 #endif
 
-  return (GD->statistics.heap +
+  return (usedStack(global) +
-	  usedStack(global) +
 	  usedStack(local) +
 	  usedStack(trail));
 }
@@ -448,8 +420,7 @@ FreeMemory(void)
 {
 #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_DATA)
   uintptr_t used = UsedMemory();
-
+  struct rlimit limit;
- struct rlimit limit;
 
   if ( getrlimit(RLIMIT_DATA, &limit) == 0 )
     return limit.rlim_cur - used;
@@ -470,7 +441,7 @@ FreeMemory(void)
     some systems (__WINDOWS__) the seed of rand() is thread-local, while on
     others it is global.  We appear to have the choice between
 
-    	# srand()/rand()
+	# srand()/rand()
 	Differ in MT handling, often bad distribution
 
 	# srandom()/random()
@@ -522,16 +493,14 @@ _PL_Random(void)
   }
 
 #ifdef HAVE_RANDOM
-#if SIZEOF_VOIDP == 4
   { uint64_t l = random();
 
-    l ^= (uint64_t)random()<<32;
+    l ^= (uint64_t)random()<<15;
+    l ^= (uint64_t)random()<<30;
+    l ^= (uint64_t)random()<<45;
 
     return l;
   }
-#else
-  return random();
-#endif
 #else
   { uint64_t l = rand();			/* 0<n<2^15-1 */
 
@@ -845,19 +814,16 @@ struct canonical_dir
 forwards char   *canoniseDir(char *);
 #endif /*O_CANONISE_DIRS*/
 
-#define CWDdir	(LD->os._CWDdir)	/* current directory */
-#define CWDlen	(LD->os._CWDlen)	/* strlen(CWDdir) */
-
 static void
 initExpand(void)
-{ GET_LD
+{
 #ifdef O_CANONISE_DIRS
   char *dir;
   char *cpaths;
 #endif
 
-  CWDdir = NULL;
+  GD->paths.CWDdir = NULL;
-  CWDlen = 0;
+  GD->paths.CWDlen = 0;
 
 #ifdef O_CANONISE_DIRS
 { char envbuf[MAXPATHLEN];
@@ -898,7 +864,15 @@ cleanupExpand(void)
   canonical_dirlist = NULL;
   for( ; dn; dn = next )
   { next = dn->next;
-    free(dn);
+    if ( dn->canonical && dn->canonical != dn->name )
+      remove_string(dn->canonical);
+    remove_string(dn->name);
+    PL_free(dn);
+  }
+  if ( GD->paths.CWDdir )
+  { remove_string(GD->paths.CWDdir);
+    GD->paths.CWDdir = NULL;
+    GD->paths.CWDlen = 0;
   }
 }
 
@@ -925,7 +899,7 @@ registerParentDirs(const char *path)
     }
 
     if ( statfunc(OsPath(dirname, tmp), &buf) == 0 )
-    { CanonicalDir dn   = malloc(sizeof(*dn));
+    { CanonicalDir dn   = PL_malloc(sizeof(*dn));
 
       dn->name		= store_string(dirname);
       dn->inode		= buf.st_ino;
@@ -980,7 +954,7 @@ verify_entry(CanonicalDir d)
     remove_string(d->name);
     if ( d->canonical != d->name )
       remove_string(d->canonical);
-    free(d);
+    PL_free(d);
   }
 
   return FALSE;
@@ -1008,12 +982,12 @@ canoniseDir(char *path)
   }
 
 					/* we need to use malloc() here */
-					/* because allocHeap() only ensures */
+					/* because allocHeapOrHalt() only ensures */
 					/* alignment for `word', and inode_t */
 					/* is sometimes bigger! */
 
   if ( statfunc(OsPath(path, tmp), &buf) == 0 )
-  { CanonicalDir dn = malloc(sizeof(*dn));
+  { CanonicalDir dn = PL_malloc(sizeof(*dn));
     char dirname[MAXPATHLEN];
     char *e = path + strlen(path);
 
@@ -1082,8 +1056,7 @@ cleanupExpand(void)
 char *
 canoniseFileName(char *path)
 { char *out = path, *in = path, *start = path;
-  char *osave[100];
+  tmp_buffer saveb;
-  int  osavep = 0;
 
 #ifdef O_HASDRIVES			/* C: */
   if ( in[1] == ':' && isLetter(in[0]) )
@@ -1092,8 +1065,8 @@ canoniseFileName(char *path)
     out = start = in;
   }
 #ifdef __MINGW32__ /* /c/ in MINGW is the same as c: */
-  if ( in[0] == '/' && isLetter(in[1]) &&
+  else if ( in[0] == '/' && isLetter(in[1]) &&
-       in[2] == '/' )
+	    in[2] == '/' )
   {
     out[0] = in[1];
     out[1] = ':';
@@ -1101,13 +1074,13 @@ canoniseFileName(char *path)
     out = start = in;
   }
 #endif
-
 #endif
+
 #ifdef O_HASSHARES			/* //host/ */
   if ( in[0] == '/' && in[1] == '/' && isAlpha(in[2]) )
   { char *s;
 
-    for(s = in+3; *s && (isAlpha(*s) || *s == '.'); s++)
+    for(s = in+3; *s && (isAlpha(*s) || *s == '-' || *s == '.'); s++)
       ;
     if ( *s == '/' )
     { in = out = s+1;
@@ -1122,7 +1095,8 @@ canoniseFileName(char *path)
     in += 2;
   if ( in[0] == '/' )
     *out++ = '/';
-  osave[osavep++] = out;
+  initBuffer(&saveb);
+  addBuffer(&saveb, out, char*);
 
   while(*in)
   { if (*in == '/')
@@ -1138,15 +1112,15 @@ canoniseFileName(char *path)
 	  }
 	  if ( in[2] == EOS )		/* delete trailing /. */
 	  { *out = EOS;
-	    return path;
+	    goto out;
 	  }
 	  if ( in[2] == '.' && (in[3] == '/' || in[3] == EOS) )
-	  { if ( osavep > 0 )		/* delete /foo/../ */
+	  { if ( !isEmptyBuffer(&saveb) )		/* delete /foo/../ */
-	    { out = osave[--osavep];
+	    { out = popBuffer(&saveb, char*);
 	      in += 3;
 	      if ( in[0] == EOS && out > start+1 )
 	      { out[-1] = EOS;		/* delete trailing / */
-		return path;
+		goto out;
 	      }
 	      goto again;
 	    } else if (	start[0] == '/' && out == start+1 )
@@ -1160,12 +1134,15 @@ canoniseFileName(char *path)
 	in++;
       if ( out > path && out[-1] != '/' )
 	*out++ = '/';
-      osave[osavep++] = out;
+      addBuffer(&saveb, out, char*);
     } else
       *out++ = *in++;
   }
   *out++ = *in++;
 
+out:
+  discardBuffer(&saveb);
+
   return path;
 }
 
@@ -1201,15 +1178,18 @@ canonisePath(char *path)
 #ifdef O_CANONISE_DIRS
 { char *e;
   char dirname[MAXPATHLEN];
+  size_t plen = strlen(path);
 
-  e = path + strlen(path) - 1;
+  if ( plen > 0 )
-  for( ; *e != '/' && e > path; e-- )
+  { e = path + plen - 1;
-    ;
+    for( ; *e != '/' && e > path; e-- )
-  strncpy(dirname, path, e-path);
+      ;
-  dirname[e-path] = EOS;
+    strncpy(dirname, path, e-path);
-  canoniseDir(dirname);
+    dirname[e-path] = EOS;
-  strcat(dirname, e);
+    canoniseDir(dirname);
-  strcpy(path, dirname);
+    strcat(dirname, e);
+    strcpy(path, dirname);
+  }
 }
 #endif
 
@@ -1238,11 +1218,12 @@ takeWord(const char **string, char *wrd, int maxlen)
 }
 
 
-bool
+char *
 expandVars(const char *pattern, char *expanded, int maxlen)
 { GET_LD
   int size = 0;
   char wordbuf[MAXPATHLEN];
+  char *rc = expanded;
 
   if ( *pattern == '~' )
   { char *user;
@@ -1305,7 +1286,9 @@ expandVars(const char *pattern, char *expanded, int maxlen)
 #endif
     size += (l = (int) strlen(value));
     if ( size+1 >= maxlen )
-      return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length);
+    { PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length);
+      return NULL;
+    }
     strcpy(expanded, value);
     expanded += l;
     UNLOCK();
@@ -1345,8 +1328,9 @@ expandVars(const char *pattern, char *expanded, int maxlen)
 	  size += (l = (int)strlen(value));
 	  if ( size+1 >= maxlen )
 	  { UNLOCK();
-	    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
+	    PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
-			    ATOM_max_path_length);
+		     ATOM_max_path_length);
+	    return NULL;
 	  }
 	  strcpy(expanded, value);
 	  UNLOCK();
@@ -1359,8 +1343,10 @@ expandVars(const char *pattern, char *expanded, int maxlen)
       def:
 	size++;
 	if ( size+1 >= maxlen )
-	  return PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
+	{ PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
-			  ATOM_max_path_length);
+		   ATOM_max_path_length);
+	  return NULL;
+	}
 	*expanded++ = c;
 
 	continue;
@@ -1369,61 +1355,14 @@ expandVars(const char *pattern, char *expanded, int maxlen)
   }
 
   if ( ++size >= maxlen )
-    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
+  { PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
-		    ATOM_max_path_length);
+	     ATOM_max_path_length);
+    return NULL;
+  }
+
   *expanded = EOS;
 
-  succeed;
+  return rc;
-}
-
-
-static int
-ExpandFile(const char *pattern, char **vector)
-{ char expanded[MAXPATHLEN];
-  int matches = 0;
-
-  if ( !expandVars(pattern, expanded, sizeof(expanded)) )
-    return -1;
-
-  vector[matches++] = store_string(expanded);
-
-  return matches;
-}
-
-
-char *
-ExpandOneFile(const char *spec, char *file)
-{ GET_LD
-  char *vector[256];
-  int size;
-
-  switch( (size=ExpandFile(spec, vector)) )
-  { case -1:
-      return NULL;
-    case 0:
-    { term_t tmp = PL_new_term_ref();
-
-      PL_put_atom_chars(tmp, spec);
-      PL_error(NULL, 0, "no match", ERR_EXISTENCE, ATOM_file, tmp);
-
-      return NULL;
-    }
-    case 1:
-      strcpy(file, vector[0]);
-      remove_string(vector[0]);
-      return file;
-    default:
-    { term_t tmp = PL_new_term_ref();
-      int n;
-
-      for(n=0; n<size; n++)
-	remove_string(vector[n]);
-      PL_put_atom_chars(tmp, spec);
-      PL_error(NULL, 0, "ambiguous", ERR_EXISTENCE, ATOM_file, tmp);
-
-      return NULL;
-    }
-  }
 }
 
 
@@ -1507,7 +1446,7 @@ AbsoluteFile(const char *spec, char *path)
   if ( !file )
      return (char *) NULL;
   if ( truePrologFlag(PLFLAG_FILEVARS) )
-  { if ( !(file = ExpandOneFile(buf, tmp)) )
+  { if ( !(file = expandVars(buf, tmp, sizeof(tmp))) )
       return (char *) NULL;
   }
 
@@ -1530,17 +1469,17 @@ AbsoluteFile(const char *spec, char *path)
   }
 #endif /*O_HASDRIVES*/
 
-  if ( !PL_cwd() )
+  if ( !PL_cwd(path, MAXPATHLEN) )
     return NULL;
 
-  if ( (CWDlen + strlen(file) + 1) >= MAXPATHLEN )
+  if ( (GD->paths.CWDlen + strlen(file) + 1) >= MAXPATHLEN )
   { PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length);
     return (char *) NULL;
   }
 
-  strcpy(path, CWDdir);
+  strcpy(path, GD->paths.CWDdir);
   if ( file[0] != EOS )
-    strcpy(&path[CWDlen], file);
+    strcpy(&path[GD->paths.CWDlen], file);
   if ( strchr(file, '.') || strchr(file, '/') )
     return canonisePath(path);
   else
@@ -1550,20 +1489,20 @@ AbsoluteFile(const char *spec, char *path)
 
 void
 PL_changed_cwd(void)
-{ GET_LD
+{ LOCK();
-
+  if ( GD->paths.CWDdir )
-  if ( CWDdir )
+    remove_string(GD->paths.CWDdir);
-    remove_string(CWDdir);
+  GD->paths.CWDdir = NULL;
-  CWDdir = NULL;
+  GD->paths.CWDlen = 0;
-  CWDlen = 0;
+  UNLOCK();
 }
 
 
-const char *
+static char *
-PL_cwd(void)
+cwd_unlocked(char *cwd, size_t cwdlen)
 { GET_LD
 
-  if ( CWDlen == 0 )
+  if ( GD->paths.CWDlen == 0 )
   { char buf[MAXPATHLEN];
     char *rval;
 
@@ -1593,16 +1532,34 @@ to be implemented directly.  What about other Unixes?
     }
 
     canonisePath(buf);
-    CWDlen = strlen(buf);
+    GD->paths.CWDlen = strlen(buf);
-    buf[CWDlen++] = '/';
+    buf[GD->paths.CWDlen++] = '/';
-    buf[CWDlen] = EOS;
+    buf[GD->paths.CWDlen] = EOS;
 
-    if ( CWDdir )
+    if ( GD->paths.CWDdir )
-      remove_string(CWDdir);
+      remove_string(GD->paths.CWDdir);
-    CWDdir = store_string(buf);
+    GD->paths.CWDdir = store_string(buf);
   }
 
-  return (const char *)CWDdir;
+  if ( GD->paths.CWDlen < cwdlen )
+  { memcpy(cwd, GD->paths.CWDdir, GD->paths.CWDlen+1);
+    return cwd;
+  } else
+  { PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length);
+    return NULL;
+  }
+}
+
+
+char *
+PL_cwd(char *cwd, size_t cwdlen)
+{ char *rc;
+
+  LOCK();
+  rc = cwd_unlocked(cwd, cwdlen);
+  UNLOCK();
+
+  return rc;
 }
 
 
@@ -1652,14 +1609,13 @@ DirName(const char *f, char *dir)
 
 bool
 ChDir(const char *path)
-{ GET_LD
+{ char ospath[MAXPATHLEN];
-  char ospath[MAXPATHLEN];
   char tmp[MAXPATHLEN];
 
   OsPath(path, ospath);
 
   if ( path[0] == EOS || streq(path, ".") ||
-       (CWDdir && streq(path, CWDdir)) )
+       (GD->paths.CWDdir && streq(path, GD->paths.CWDdir)) )
     succeed;
 
   AbsoluteFile(path, tmp);
@@ -1672,10 +1628,12 @@ ChDir(const char *path)
     { tmp[len++] = '/';
       tmp[len] = EOS;
     }
-    CWDlen = len;
+    LOCK();					/* Lock with PL_changed_cwd() */
-    if ( CWDdir )
+    GD->paths.CWDlen = len;			/* and PL_cwd() */
-      remove_string(CWDdir);
+    if ( GD->paths.CWDdir )
-    CWDdir = store_string(tmp);
+      remove_string(GD->paths.CWDdir);
+    GD->paths.CWDdir = store_string(tmp);
+    UNLOCK();
 
     succeed;
   }
@@ -1689,7 +1647,7 @@ ChDir(const char *path)
 		*********************************/
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-    struct tm *LocalTime(time_t time, struct tm *r)
+    struct tm *PL_localtime_r(time_t time, struct tm *r)
 
     Convert time in Unix internal form (seconds since Jan 1 1970) into a
     structure providing easier access to the time.
@@ -1713,17 +1671,52 @@ ChDir(const char *path)
     time_t Time()
 
     Return time in seconds after Jan 1 1970 (Unix' time notion).
+
+Note: MinGW has localtime_r(),  but  it  is   not  locked  and  thus not
+thread-safe. MinGW does not have localtime_s(), but   we  test for it in
+configure.
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 struct tm *
-LocalTime(long *t, struct tm *r)
+PL_localtime_r(const time_t *t, struct tm *r)
 {
-#if defined(_REENTRANT) && defined(HAVE_LOCALTIME_R)
+#ifdef HAVE_LOCALTIME_R
   return localtime_r(t, r);
 #else
-  *r = *localtime((const time_t *) t);
+#ifdef HAVE_LOCALTIME_S
+  return localtime_s(r, t) == EINVAL ? NULL : t;
+#else
+  struct tm *rc;
+
+  LOCK();
+  if ( (rc = localtime(t)) )
+    *r = *rc;
+  else
+    r = NULL;
+  UNLOCK();
+
   return r;
 #endif
+#endif
+}
+
+char *
+PL_asctime_r(const struct tm *tm, char *buf)
+{
+#ifdef HAVE_ASCTIME_R
+  return asctime_r(tm, buf);
+#else
+  char *rc;
+
+  LOCK();
+  if ( (rc = asctime(tm)) )
+    strcpy(buf, rc);
+  else
+    buf = NULL;
+  UNLOCK();
+
+  return buf;
+#endif
 }
 
 
@@ -1857,7 +1850,7 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
   if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
     succeed;
 
-  buf->state = allocHeap(sizeof(tty_state));
+  buf->state = allocHeapOrHalt(sizeof(tty_state));
 
 #ifdef HAVE_TCSETATTR
   if ( tcgetattr(fd, &TTY_STATE(buf)) )	/* save the old one */
@@ -1915,9 +1908,7 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
 
 bool
 PopTty(IOSTREAM *s, ttybuf *buf, int do_free)
-{ GET_LD
+{ ttymode = buf->mode;
-
-  ttymode = buf->mode;
 
   if ( buf->state )
   { int fd = Sfileno(s);
@@ -1963,7 +1954,7 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
   if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
     succeed;
 
-  buf->state = allocHeap(sizeof(tty_state));
+  buf->state = allocHeapOrHalt(sizeof(tty_state));
 
   if ( ioctl(fd, TIOCGETP, &TTY_STATE(buf)) )  /* save the old one */
     fail;
@@ -2178,7 +2169,7 @@ growEnviron(char **e, int amount)
     for(e1=e, filled=0; *e1; e1++, filled++)
       ;
     size = ROUND(filled+10+amount, 32);
-    env = (char **)malloc(size * sizeof(char *));
+    env = (char **)PL_malloc(size * sizeof(char *));
     for ( e1=e, e2=env; *e1; *e2++ = *e1++ )
       ;
     *e2 = (char *) NULL;
@@ -2192,7 +2183,7 @@ growEnviron(char **e, int amount)
   { char **env, **e1, **e2;
 
     size += 32;
-    env = (char **)realloc(e, size * sizeof(char *));
+    env = (char **)PL_realloc(e, size * sizeof(char *));
     for ( e1=e, e2=env; *e1; *e2++ = *e1++ )
       ;
     *e2 = (char *) NULL;
@@ -2224,9 +2215,9 @@ matchName(const char *e, const char *name)
 
 static void
 setEntry(char **e, char *name, char *value)
-{ int l = (int)strlen(name);
+{ size_t l = strlen(name);
 
-  *e = (char *) malloc(l + strlen(value) + 2);
+  *e = PL_malloc_atomic(l + strlen(value) + 2);
   strcpy(*e, name);
   e[0][l++] = '=';
   strcpy(&e[0][l], value);
@@ -2292,7 +2283,7 @@ Unsetenv(char *name)
     an alternative.
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
-#if defined(__unix__)
+#ifdef __unix__
 #define SPECIFIC_SYSTEM 1
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -2465,30 +2456,15 @@ char *command;
 
 #endif
 
-/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-[candidate]
-
-exec(+Cmd, [+In, +Out, +Error], -Pid)
-
-The streams may be one of standard   stream,  std, null stream, null, or
-pipe(S), where S is a pipe stream
-
-Detach if none is std!
-
-TBD: Sort out status. The above is SICStus 3. YAP uses `Status' for last
-argument (strange). SICStus 4 appears to drop this altogether.
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-
-
-
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-    char *Symbols(char *buf)
+    char *findExecutable(char *buf)
 
     Return the path name of the executable of SWI-Prolog.
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 #ifndef __WINDOWS__			/* Win32 version in pl-nt.c */
+static char *	Which(const char *program, char *fullname);
 
 char *
 findExecutable(const char *av0, char *buffer)
@@ -2500,7 +2476,7 @@ findExecutable(const char *av0, char *buffer)
     return NULL;
   file = Which(buf, tmp);
 
-#if __unix__ 		/* argv[0] can be an #! script! */
+#if __unix__				/* argv[0] can be an #! script! */
   if ( file )
   { int n, fd;
     char buf[MAXPATHLEN];
@@ -2532,14 +2508,8 @@ findExecutable(const char *av0, char *buffer)
 
   return strcpy(buffer, file ? file : buf);
 }
-#endif /*__WINDOWS__*/
 
-
+#ifdef __unix__
-#if defined(OS2) || defined(__DOS__) || defined(__WINDOWS__)
-#define EXEC_EXTENSIONS { ".exe", ".com", ".bat", ".cmd", NULL }
-#define PATHSEP ';'
-#else
-/* not Windows, must be a Linux-like thingy */
 static char *
 okToExec(const char *s)
 { statstruct stbuff;
@@ -2552,6 +2522,11 @@ okToExec(const char *s)
     return (char *) NULL;
 }
 #define PATHSEP	':'
+#endif /* __unix__ */
+
+#if defined(OS2) || defined(__DOS__) || defined(__WINDOWS__)
+#define EXEC_EXTENSIONS { ".exe", ".com", ".bat", ".cmd", NULL }
+#define PATHSEP ';'
 #endif
 
 #ifdef EXEC_EXTENSIONS
@@ -2636,6 +2611,7 @@ Which(const char *program, char *fullname)
   return NULL;
 }
 
+#endif /*__WINDOWS__*/
 
 /** int Pause(double time)
 

os/pl-prologflag.c

@@ -1,11 +1,10 @@
-/*  $Id$
+/*  Part of SWI-Prolog
-
-    Part of SWI-Prolog
 
     Author:        Jan Wielemaker
-    E-mail:        J.wielemaker@uva.nl
+    E-mail:        J.wielemaker@vu.nl
     WWW:           http://www.swi-prolog.org
-    Copyright (C): 1985-2008, University of Amsterdam
+    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
@@ -19,7 +18,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 /*#define O_DEBUG 1*/
@@ -80,6 +79,8 @@ static void setTZPrologFlag(void);
 static void setVersionPrologFlag(void);
 #endif
 static atom_t lookupAtomFlag(atom_t key);
+static void initPrologFlagTable(void);
+
 
 typedef struct _prolog_flag
 { short		flags;			/* Type | Flags */
@@ -138,7 +139,7 @@ setPrologFlag(const char *name, int flags, ...)
     if ( flags & FF_KEEP )
       return;
   } else
-  { f = allocHeap(sizeof(*f));
+  { f = allocHeapOrHalt(sizeof(*f));
     f->index = -1;
     f->flags = flags;
     addHTable(GD->prolog_flag.table, (void *)an, f);
@@ -155,7 +156,8 @@ setPrologFlag(const char *name, int flags, ...)
 	val = (f->value.a == ATOM_true);
       } else if ( !s )				/* 1st definition */
       { f->index = indexOfBoolMask(mask);
-	DEBUG(2, Sdprintf("Prolog flag %s at 0x%08lx\n", name, mask));
+	DEBUG(MSG_PROLOG_FLAG,
+	      Sdprintf("Prolog flag %s at 0x%08lx\n", name, mask));
       }
 
       f->value.a = (val ? ATOM_true : ATOM_false);
@@ -211,12 +213,20 @@ setPrologFlag(const char *name, int flags, ...)
 }
 
 
+static void
+freePrologFlag(prolog_flag *f)
+{ if ( (f->flags & FT_MASK) == FT_TERM )
+    PL_erase(f->value.t);
+
+  freeHeap(f, sizeof(*f));
+}
+
+
 #ifdef O_PLMT
 static void
 copySymbolPrologFlagTable(Symbol s)
-{ GET_LD
+{ prolog_flag *f = s->value;
-  prolog_flag *f = s->value;
+  prolog_flag *copy = allocHeapOrHalt(sizeof(*copy));
-  prolog_flag *copy = allocHeap(sizeof(*copy));
 
   *copy = *f;
   if ( (f->flags & FT_MASK) == FT_TERM )
@@ -227,13 +237,7 @@ copySymbolPrologFlagTable(Symbol s)
 
 static void
 freeSymbolPrologFlagTable(Symbol s)
-{ GET_LD
+{ freePrologFlag(s->value);
-  prolog_flag *f = s->value;
-
-  if ( (f->flags & FT_MASK) == FT_TERM )
-    PL_erase(f->value.t);
-
-  freeHeap(f, sizeof(*f));
 }
 #endif
 
@@ -267,25 +271,34 @@ setDoubleQuotes(atom_t a, unsigned int *flagp)
 
 
 static int
-setUnknown(atom_t a, unsigned int *flagp)
+setUnknown(term_t value, atom_t a, Module m)
-{ unsigned int flags;
+{ unsigned int flags = m->flags & ~(UNKNOWN_MASK);
 
   if ( a == ATOM_error )
-    flags = UNKNOWN_ERROR;
+    flags |= UNKNOWN_ERROR;
   else if ( a == ATOM_warning )
-    flags = UNKNOWN_WARNING;
+    flags |= UNKNOWN_WARNING;
   else if ( a == ATOM_fail )
-    flags = UNKNOWN_FAIL;
+    flags |= UNKNOWN_FAIL;
   else
-  { GET_LD
-    term_t value = PL_new_term_ref();
-
-    PL_put_atom(value, a);
     return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_unknown, value);
+
+  if ( !(flags&UNKNOWN_ERROR) && (m == MODULE_user || m == MODULE_system) )
+  { GET_LD
+
+    if ( m == MODULE_system && !SYSTEM_MODE )
+    { term_t key = PL_new_term_ref();
+
+      PL_put_atom(key, ATOM_unknown);
+      return PL_error(NULL, 0, NULL, ERR_PERMISSION,
+		      ATOM_modify, ATOM_flag, key);
+    }
+
+    if ( !SYSTEM_MODE )
+      printMessage(ATOM_warning, PL_CHARS, "unknown_in_module_user");
   }
 
-  *flagp &= ~(UNKNOWN_MASK);
+  m->flags = flags;
-  *flagp |= flags;
 
   succeed;
 }
@@ -308,6 +321,21 @@ setWriteAttributes(atom_t a)
 }
 
 
+static int
+setAccessLevelFromAtom(atom_t a)
+{ GET_LD
+
+  if ( getAccessLevelMask(a, &LD->prolog_flag.access_level) )
+  { succeed;
+  } else
+  { term_t value = PL_new_term_ref();
+
+    PL_put_atom(value, a);
+    return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_access_level, value);
+  }
+}
+
+
 static int
 getOccursCheckMask(atom_t a, occurs_check_t *val)
 { if ( a == ATOM_false )
@@ -357,6 +385,30 @@ setEncoding(atom_t a)
 }
 
 
+static int
+setStreamTypeCheck(atom_t a)
+{ GET_LD
+  st_check check;
+
+  if ( a == ATOM_false )
+    check = ST_FALSE;
+  else if ( a == ATOM_loose )
+    check = ST_LOOSE;
+  else if ( a == ATOM_true )
+    check = ST_TRUE;
+  else
+  { term_t value = PL_new_term_ref();
+
+    PL_put_atom(value, a);
+    return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_stream_type_check, value);
+  }
+
+  LD->IO.stream_type_check = check;
+  return TRUE;
+}
+
+
+
 static word
 set_prolog_flag_unlocked(term_t key, term_t value, int flags)
 { GET_LD
@@ -385,7 +437,7 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags)
 
 #ifdef O_PLMT
     if ( GD->statistics.threads_created > 1 )
-    { prolog_flag *f2 = allocHeap(sizeof(*f2));
+    { prolog_flag *f2 = allocHeapOrHalt(sizeof(*f2));
 
       *f2 = *f;
       if ( (f2->flags & FT_MASK) == FT_TERM )
@@ -399,7 +451,8 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags)
       }
 
       addHTable(LD->prolog_flag.table, (void *)k, f2);
-      DEBUG(1, Sdprintf("Localised Prolog flag %s\n", PL_atom_chars(k)));
+      DEBUG(MSG_PROLOG_FLAG,
+	    Sdprintf("Localised Prolog flag %s\n", PL_atom_chars(k)));
       f = f2;
     }
 #endif
@@ -411,7 +464,7 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags)
 
   anyway:
     PL_register_atom(k);
-    f = allocHeap(sizeof(*f));
+    f = allocHeapOrHalt(sizeof(*f));
     f->index = -1;
 
     switch( (flags & FT_MASK) )
@@ -437,8 +490,9 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags)
 	    goto wrong_type;
 	  }
 	  if ( !(f->value.t = PL_record(value)) )
-	    goto wrong_type;
+	  { freeHeap(f, sizeof(*f));
-	  f->value.t = PL_record(value);
+	    return FALSE;
+	  }
 	}
 	break;
       }
@@ -483,7 +537,10 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags)
     if ( (flags & FF_READONLY) )
       f->flags |= FF_READONLY;
 
-    addHTable(GD->prolog_flag.table, (void *)k, f);
+    if ( !addHTable(GD->prolog_flag.table, (void *)k, f) )
+    { freePrologFlag(f);
+      Sdprintf("OOPS; failed to set Prolog flag!?\n");
+    }
 
     succeed;
   } else
@@ -516,9 +573,9 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags)
 #ifndef __YAP_PROLOG__
       if ( k == ATOM_character_escapes )
       { if ( val )
-	  set(m, CHARESCAPE);
+	  set(m, M_CHARESCAPE);
 	else
-	  clear(m, CHARESCAPE);
+	  clear(m, M_CHARESCAPE);
       } else if ( k == ATOM_debug )
       { if ( val )
 	{ debugmode(DBG_ALL, NULL);
@@ -551,15 +608,19 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags)
       if ( k == ATOM_double_quotes )
       { rval = setDoubleQuotes(a, &m->flags);
       } else if ( k == ATOM_unknown )
-      { rval = setUnknown(a, &m->flags);
+      { rval = setUnknown(value, a, m);
       } else if ( k == ATOM_write_attributes )
       { rval = setWriteAttributes(a);
       } else if ( k == ATOM_occurs_check )
       { rval = setOccursCheck(a);
+      } else if ( k == ATOM_access_level )
+      { rval = setAccessLevelFromAtom(a);
       } else
 #endif
       if ( k == ATOM_encoding )
       { rval = setEncoding(a);
+      } else if ( k == ATOM_stream_type_check )
+      { rval = setStreamTypeCheck(a);
       }
       if ( !rval )
 	fail;
@@ -705,7 +766,7 @@ unify_prolog_flag_value(Module m, atom_t key, prolog_flag *f, term_t val)
 
 #ifndef __YAP_PROLOG__
   if ( key == ATOM_character_escapes )
-  { atom_t v = (true(m, CHARESCAPE) ? ATOM_true : ATOM_false);
+  { atom_t v = (true(m, M_CHARESCAPE) ? ATOM_true : ATOM_false);
 
     return PL_unify_atom(val, v);
   } else if ( key == ATOM_double_quotes )
@@ -736,6 +797,7 @@ unify_prolog_flag_value(Module m, atom_t key, prolog_flag *f, term_t val)
         break;
       default:
 	assert(0);
+        return FALSE;
     }
 
     return PL_unify_atom(val, v);
@@ -747,6 +809,14 @@ unify_prolog_flag_value(Module m, atom_t key, prolog_flag *f, term_t val)
   { return PL_unify_bool_ex(val, debugstatus.debugging);
   } else if ( key == ATOM_debugger_show_context )
   { return PL_unify_bool_ex(val, debugstatus.showContext);
+  } else if ( key == ATOM_break_level )
+  { int bl = currentBreakLevel();
+
+    if ( bl >= 0 )
+      return PL_unify_integer(val, bl);
+    return FALSE;
+  } else if ( key == ATOM_access_level )
+  { return PL_unify_atom(val, accessLevel());
   }
 #endif /* YAP_PROLOG */
 
@@ -861,7 +931,7 @@ pl_prolog_flag5(term_t key, term_t value,
 
 	fail;
       } else if ( PL_is_variable(key) )
-      { e = allocHeap(sizeof(*e));
+      { e = allocHeapOrHalt(sizeof(*e));
 
 	e->module = module;
 
@@ -965,7 +1035,7 @@ pl_prolog_flag(term_t name, term_t value, control_t h)
 #define SO_PATH "LD_LIBRARY_PATH"
 #endif
 
-void
+static void
 initPrologFlagTable(void)
 { if ( !GD->prolog_flag.table )
   { 
@@ -973,7 +1043,7 @@ initPrologFlagTable(void)
     initPrologThreads();	/* may be called before PL_initialise() */
 #endif
 
-    GD->prolog_flag.table = newHTable(32);
+    GD->prolog_flag.table = newHTable(64);
   }
 }
 
@@ -983,7 +1053,7 @@ initPrologFlags(void)
 { GET_LD
 #ifndef __YAP_PROLOG__
   setPrologFlag("iso",  FT_BOOL, FALSE, PLFLAG_ISO);
-  setPrologFlag("arch", FT_ATOM|FF_READONLY, ARCH);
+  setPrologFlag("arch", FT_ATOM|FF_READONLY, PLARCH);
 #if __WINDOWS__
   setPrologFlag("windows",	FT_BOOL|FF_READONLY, TRUE, 0);
 #endif
@@ -996,12 +1066,17 @@ initPrologFlags(void)
 #if defined(HAVE_GETPID) || defined(EMULATE_GETPID)
   setPrologFlag("pid", FT_INTEGER|FF_READONLY, getpid());
 #endif
+  setPrologFlag("optimise", FT_BOOL, GD->cmdline.optimise, PLFLAG_OPTIMISE);
   setPrologFlag("generate_debug_info", FT_BOOL,
-	     truePrologFlag(PLFLAG_DEBUGINFO), PLFLAG_DEBUGINFO);
+		truePrologFlag(PLFLAG_DEBUGINFO), PLFLAG_DEBUGINFO);
   setPrologFlag("last_call_optimisation", FT_BOOL, TRUE, PLFLAG_LASTCALL);
-  setPrologFlag("c_libs",	  FT_ATOM|FF_READONLY, C_LIBS);
+  setPrologFlag("warn_override_implicit_import", FT_BOOL, TRUE,
-  setPrologFlag("c_cc",	  FT_ATOM|FF_READONLY, C_CC);
+		PLFLAG_WARN_OVERRIDE_IMPLICIT_IMPORT);
-  setPrologFlag("c_ldflags", FT_ATOM|FF_READONLY, C_LDFLAGS);
+  setPrologFlag("c_cc",	     FT_ATOM, C_CC);
+  setPrologFlag("c_libs",    FT_ATOM, C_LIBS);
+  setPrologFlag("c_libplso", FT_ATOM, C_LIBPLSO);
+  setPrologFlag("c_ldflags", FT_ATOM, C_LDFLAGS);
+  setPrologFlag("c_cflags",  FT_ATOM, C_CFLAGS);
 #if defined(O_LARGEFILES) || SIZEOF_LONG == 8
   setPrologFlag("large_files", FT_BOOL|FF_READONLY, TRUE, 0);
 #endif
@@ -1041,6 +1116,7 @@ initPrologFlags(void)
   setPrologFlag("debug_on_error",	FT_BOOL, TRUE, PLFLAG_DEBUG_ON_ERROR);
   setPrologFlag("report_error",	FT_BOOL, TRUE, PLFLAG_REPORT_ERROR);
 #endif
+  setPrologFlag("break_level", FT_INTEGER|FF_READONLY, 0, 0);
   setPrologFlag("user_flags", FT_ATOM, "silent");
   setPrologFlag("editor", FT_ATOM, "default");
   setPrologFlag("debugger_show_context", FT_BOOL, FALSE, 0);
@@ -1065,28 +1141,39 @@ initPrologFlags(void)
     setPrologFlag("integer_rounding_function", FT_ATOM|FF_READONLY, "toward_zero");
   setPrologFlag("max_arity", FT_ATOM|FF_READONLY, "unbounded");
   setPrologFlag("answer_format", FT_ATOM, "~p");
+  setPrologFlag("colon_sets_calling_context", FT_BOOL, TRUE, 0);
   setPrologFlag("character_escapes", FT_BOOL, TRUE, PLFLAG_CHARESCAPE);
   setPrologFlag("char_conversion", FT_BOOL, FALSE, PLFLAG_CHARCONVERSION);
   setPrologFlag("backquoted_string", FT_BOOL, FALSE, PLFLAG_BACKQUOTED_STRING);
   setPrologFlag("write_attributes", FT_ATOM, "ignore");
+  setPrologFlag("stream_type_check", FT_ATOM, "loose");
   setPrologFlag("occurs_check", FT_ATOM, "false");
+  setPrologFlag("access_level", FT_ATOM, "user");
   setPrologFlag("double_quotes", FT_ATOM, "codes");
   setPrologFlag("unknown", FT_ATOM, "error");
   setPrologFlag("debug", FT_BOOL, FALSE, 0);
   setPrologFlag("verbose", FT_ATOM|FF_KEEP, GD->options.silent ? "silent" : "normal");
-  setPrologFlag("verbose_load", FT_BOOL, TRUE, 0);
+  setPrologFlag("verbose_load", FT_ATOM, "normal");
   setPrologFlag("verbose_autoload", FT_BOOL, FALSE, 0);
   setPrologFlag("verbose_file_search", FT_BOOL, FALSE, 0);
   setPrologFlag("allow_variable_name_as_functor", FT_BOOL, FALSE,
 	     ALLOW_VARNAME_FUNCTOR);
   setPrologFlag("toplevel_var_size", FT_INTEGER, 1000);
   setPrologFlag("toplevel_print_anon", FT_BOOL, TRUE, 0);
+  setPrologFlag("toplevel_prompt", FT_ATOM, "~m~d~l~! ?- ");
+  setPrologFlag("file_name_variables", FT_BOOL, FALSE, PLFLAG_FILEVARS);
+  setPrologFlag("fileerrors", FT_BOOL, TRUE, PLFLAG_FILEERRORS);
 #ifdef __unix__
   setPrologFlag("unix", FT_BOOL|FF_READONLY, TRUE, 0);
 #endif
 
+  setPrologFlag("encoding", FT_ATOM, stringAtom(encoding_to_atom(LD->encoding)));
+
+  setPrologFlag("tty_control", FT_BOOL,
+		truePrologFlag(PLFLAG_TTY_CONTROL), PLFLAG_TTY_CONTROL);
   setPrologFlag("signals", FT_BOOL|FF_READONLY,
-	     truePrologFlag(PLFLAG_SIGNALS), PLFLAG_SIGNALS);
+		truePrologFlag(PLFLAG_SIGNALS), PLFLAG_SIGNALS);
+  setPrologFlag("readline", FT_BOOL/*|FF_READONLY*/, FALSE, 0);
 
 #if defined(__WINDOWS__) && defined(_DEBUG)
   setPrologFlag("kernel_compile_mode", FT_ATOM|FF_READONLY, "debug");
@@ -1124,7 +1211,7 @@ initPrologFlags(void)
 
 #ifndef __YAP_PROLOG__
 static void
-setArgvPrologFlag()
+setArgvPrologFlag(void)
 { GET_LD
   fid_t fid = PL_open_foreign_frame();
   term_t e = PL_new_term_ref();
@@ -1148,7 +1235,7 @@ setArgvPrologFlag()
 #endif
 
 static void
-setTZPrologFlag()
+setTZPrologFlag(void)
 { tzset();
 
   setPrologFlag("timezone", FT_INTEGER|FF_READONLY, timezone);
@@ -1166,7 +1253,7 @@ setVersionPrologFlag(void)
   int patch = (PLVERSION%100);
 
   if ( !PL_unify_term(t,
-		      PL_FUNCTOR_CHARS, "swi", 4,
+		      PL_FUNCTOR_CHARS, PLNAME, 4,
 		        PL_INT, major,
 		        PL_INT, minor,
 		        PL_INT, patch,
@@ -1179,6 +1266,19 @@ setVersionPrologFlag(void)
   setGITVersion();
 }
 #endif /* YAP_PROLOG */
+
+void
+cleanupPrologFlags(void)
+{ if ( GD->prolog_flag.table )
+  { Table t = GD->prolog_flag.table;
+
+    GD->prolog_flag.table = NULL;
+    t->free_symbol = freeSymbolPrologFlagTable;
+    destroyHTable(t);
+  }
+}
+
+
 		 /*******************************
 		 *      PUBLISH PREDICATES	*
 		 *******************************/

os/pl-rl.c

@@ -19,7 +19,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -40,7 +40,7 @@ SWI-Prolog.h and SWI-Stream.h
 #include "SWI-Stream.h"
 #include "SWI-Prolog.h"
 
-#if defined(__WINDOWS__) && !defined(__YAP_PROLOG__)
+#ifdef __WINDOWS__
 #ifdef WIN64
 #include "config/win64.h"
 #else
@@ -102,7 +102,6 @@ extern void add_history(char *);	/* should be in readline.h */
 extern int rl_begin_undo_group(void);	/* delete when conflict arrises! */
 extern int rl_end_undo_group(void);
 extern Function *rl_event_hook;
-
 #ifndef HAVE_RL_FILENAME_COMPLETION_FUNCTION
 #define rl_filename_completion_function filename_completion_function
 extern char *filename_completion_function(const char *, int);
@@ -368,7 +367,6 @@ input_on_fd(int fd)
   return select(fd+1, &rfds, NULL, NULL, &tv) != 0;
 }
 
-
 static int
 event_hook(void)
 { if ( Sinput->position )
@@ -487,9 +485,8 @@ Sread_readline(void *handle, char *buf, size_t size)
 	  rl_prep_terminal(FALSE);
 	  rl_readline_state = state;
 	  rl_done = 0;
-	} else {
+	} else
 	  line = pl_readline(prompt);
-	}
 	in_readline--;
 
 	if ( my_prompt )
@@ -515,31 +512,26 @@ Sread_readline(void *handle, char *buf, size_t size)
     }
   }
 
-#ifdef HAVE_CLOCK
-  PL_clock_wait_ticks(clock() - oldclock);
-#endif
-
   return rval;
 }
 
 
 static int
 prolog_complete(int ignore, int key)
-{ 
+{ if ( rl_point > 0 && rl_line_buffer[rl_point-1] != ' ' )
-  if ( rl_point > 0 && rl_line_buffer[rl_point-1] != ' ' )
+  { rl_begin_undo_group();
-    { rl_begin_undo_group();
+    rl_complete(ignore, key);
-      rl_complete(ignore, key);
+    if ( rl_point > 0 && rl_line_buffer[rl_point-1] == ' ' )
-      if ( rl_point > 0 && rl_line_buffer[rl_point-1] == ' ' )
+    {
-	{
 #ifdef HAVE_RL_INSERT_CLOSE		/* actually version >= 1.2 */
-	  rl_delete_text(rl_point-1, rl_point);
+      rl_delete_text(rl_point-1, rl_point);
-	  rl_point -= 1;
+      rl_point -= 1;
 #else
-	  rl_delete(-1, key);
+      rl_delete(-1, key);
 #endif
-	}
+    }
-      rl_end_undo_group();
+    rl_end_undo_group();
-    } else
+  } else
     rl_complete(ignore, key);
 
   return 0;
@@ -551,7 +543,12 @@ atom_generator(const char *prefix, int state)
 { char *s = PL_atom_generator(prefix, state);
 
   if ( s )
-    return strcpy(PL_malloc(1 + strlen(s)), s);
+  { char *copy = malloc(1 + strlen(s));
+
+    if ( copy )				/* else pretend no completion */
+      strcpy(copy, s);
+    s = copy;
+  }
 
   return s;
 }
@@ -574,20 +571,26 @@ prolog_completion(const char *text, int start, int end)
 
 #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
-  bool old;
+  access_level_t alevel;
 
 #ifndef __WINDOWS__
   if ( !truePrologFlag(PLFLAG_TTY_CONTROL) || !isatty(0) )
     return;
 #endif
 
-  old = systemMode(TRUE);
+  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__
@@ -599,6 +602,9 @@ PL_install_readline(void)
 #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 */
@@ -607,14 +613,17 @@ PL_install_readline(void)
   Soutput->functions = &GD->os.rl_functions;
   Serror->functions  = &GD->os.rl_functions;
 
-  PL_register_foreign("rl_read_init_file", 1, pl_rl_read_init_file, 0);
+#define PRED(name, arity, func, attr) \
-  PL_register_foreign("rl_add_history",    1, pl_rl_add_history, PL_FA_NOTRACE);
+	PL_register_foreign_in_module("system", name, arity, func, attr)
-  PL_register_foreign("rl_write_history",  1, pl_rl_write_history, 0);
+
-  PL_register_foreign("rl_read_history",   1, pl_rl_read_history, 0);
+  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");
-  systemMode(old);
+  setAccessLevel(alevel);
 }
 
 #else /*HAVE_LIBREADLINE*/

os/pl-stream.c

@@ -1,11 +1,10 @@
-/*  $Id$
+/*  Part of SWI-Prolog
-
-    Part of SWI-Prolog
 
     Author:        Jan Wielemaker
-    E-mail:        J.Wielemaker@uva.nl
+    E-mail:        J.Wielemaker@vu.nl
     WWW:           http://www.swi-prolog.org
-    Copyright (C): 1985-2009, University of Amsterdam
+    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
@@ -19,21 +18,21 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
-#if defined(__WINDOWS__)||defined(__WIN32)
+#ifdef __WINDOWS__
-#include <windows/uxnt.h>
+#include "windows/uxnt.h"
-#ifndef _YAP_NOT_INSTALLED_
 #ifdef WIN64
-#define MD "config/win64.h"
+#include "config/win64.h"
 #else
-#define MD "config/win32.h"
+#include "config/win32.h"
-#endif
 #endif
 #include <winsock2.h>
 #include "windows/mswchar.h"
 #define CRLF_MAPPING 1
+#else
+#include <config.h>
 #endif
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -48,12 +47,6 @@ recursive locks. If a stream handle  might   be  known to another thread
 locking is required.
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
-#ifdef MD
-#include MD
-#else
-#include <config.h>
-#endif
-
 #if _FILE_OFFSET_BITS == 64 || defined(_LARGE_FILES)
 #define O_LARGEFILES 1		/* use for conditional code in Prolog */
 #else
@@ -62,8 +55,9 @@ locking is required.
 
 #define PL_KERNEL 1
 #include <wchar.h>
-typedef wchar_t pl_wchar_t;
+#define NEEDS_SWINSOCK
 #include "SWI-Stream.h"
+#include "SWI-Prolog.h"
 #include "pl-utf8.h"
 #include <sys/types.h>
 #ifdef HAVE_SYS_TIME_H
@@ -104,7 +98,7 @@ typedef wchar_t pl_wchar_t;
 #endif
 
 #define ROUND(p, n) ((((p) + (n) - 1) & ~((n) - 1)))
-#define UNDO_SIZE ROUND(MB_LEN_MAX, sizeof(wchar_t))
+#define UNDO_SIZE ROUND(PL_MB_LEN_MAX, sizeof(wchar_t))
 
 #ifndef FALSE
 #define FALSE 0
@@ -127,7 +121,7 @@ static int	S__seterror(IOSTREAM *s);
 #ifdef O_PLMT
 #define SLOCK(s)    if ( s->mutex ) recursiveMutexLock(s->mutex)
 #define SUNLOCK(s)  if ( s->mutex ) recursiveMutexUnlock(s->mutex)
-static inline int
+inline int
 STRYLOCK(IOSTREAM *s)
 { if ( s->mutex &&
        recursiveMutexTryLock(s->mutex) == EBUSY )
@@ -141,13 +135,9 @@ STRYLOCK(IOSTREAM *s)
 #define STRYLOCK(s) (TRUE)
 #endif
 
-typedef void *record_t;
-typedef void *Module;
-typedef intptr_t term_t;
-typedef intptr_t atom_t;
 #include "pl-error.h"
 
-extern int 			fatalError(const char *fm, ...);
+extern int			fatalError(const char *fm, ...);
 extern int			PL_handle_signals(void);
 extern IOENC			initEncoding(void);
 extern int			reportStreamError(IOSTREAM *s);
@@ -368,6 +358,69 @@ Sunlock(IOSTREAM *s)
 }
 
 
+		 /*******************************
+		 *		TIMEOUT		*
+		 *******************************/
+
+#ifdef HAVE_SELECT
+
+#ifndef __WINDOWS__
+typedef int SOCKET;
+#define INVALID_SOCKET -1
+#define Swinsock(s) Sfileno(s)
+#define NFDS(n) (n+1)
+#else
+#define NFDS(n) (0)			/* 1st arg of select is ignored */
+#endif
+
+
+static int
+S__wait(IOSTREAM *s)
+{ SOCKET fd = Swinsock(s);
+  fd_set wait;
+  struct timeval time;
+  int rc;
+
+  if ( fd == INVALID_SOCKET )
+  { errno = EPERM;			/* no permission to select */
+    s->flags |= SIO_FERR;
+    return -1;
+  }
+
+  time.tv_sec  = s->timeout / 1000;
+  time.tv_usec = (s->timeout % 1000) * 1000;
+  FD_ZERO(&wait);
+  FD_SET(fd, &wait);
+
+  for(;;)
+  { if ( (s->flags & SIO_INPUT) )
+      rc = select(NFDS(fd), &wait, NULL, NULL, &time);
+    else
+      rc = select(NFDS(fd), NULL, &wait, NULL, &time);
+
+    if ( rc < 0 && errno == EINTR )
+    { if ( PL_handle_signals() < 0 )
+      { errno = EPLEXCEPTION;
+	return -1;
+      }
+
+      continue;
+    }
+
+    break;
+  }
+
+  if ( rc == 0 )
+  { s->flags |= (SIO_TIMEOUT|SIO_FERR);
+    return -1;
+  }
+
+  return 0;				/* ok, data available */
+}
+
+#endif /*HAVE_SELECT*/
+
+
 		 /*******************************
 		 *	     FLUSH/FILL		*
 		 *******************************/
@@ -385,7 +438,18 @@ S__flushbuf(IOSTREAM *s)
 
   while ( from < to )
   { size_t size = (size_t)(to - from);
-    ssize_t n = (*s->functions->write)(s->handle, from, size);
+    ssize_t n;
+
+#ifdef HAVE_SELECT
+    s->flags &= ~SIO_TIMEOUT;
+
+    if ( s->timeout >= 0 )
+    { if ( (rc=S__wait(s)) < 0 )
+	goto partial;
+    }
+#endif
+
+    n = (*s->functions->write)(s->handle, from, size);
 
     if ( n > 0 )			/* wrote some */
     { from += n;
@@ -398,6 +462,9 @@ S__flushbuf(IOSTREAM *s)
     }
   }
 
+#ifdef HAVE_SELECT
+partial:
+#endif
   if ( to == from )			/* full flush */
   { rc = s->bufp - s->buffer;
     s->bufp = s->buffer;
@@ -442,52 +509,6 @@ S__flushbufc(int c, IOSTREAM *s)
 }
 
 
-static int
-Swait_for_data(IOSTREAM *s)
-{ int fd = Sfileno(s);
-  fd_set wait;
-  struct timeval time;
-  int rc;
-
-  if ( fd < 0 )
-  { errno = EPERM;			/* no permission to select */
-    s->flags |= SIO_FERR;
-    return -1;
-  }
-
-  time.tv_sec  = s->timeout / 1000;
-  time.tv_usec = (s->timeout % 1000) * 1000;
-  FD_ZERO(&wait);
-#ifdef __WINDOWS__
-  FD_SET((SOCKET)fd, &wait);
-#else
-  FD_SET(fd, &wait);
-#endif
-
-  for(;;)
-  { rc = select(fd+1, &wait, NULL, NULL, &time);
-
-    if ( rc < 0 && errno == EINTR )
-    { if ( PL_handle_signals() < 0 )
-      { errno = EPLEXCEPTION;
-	return -1;
-      }
-
-      continue;
-    }
-
-    break;
-  }
-
-  if ( rc == 0 )
-  { s->flags |= (SIO_TIMEOUT|SIO_FERR);
-    return -1;
-  }
-
-  return 0;				/* ok, data available */
-}
-
-
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 S__fillbuf() fills the read-buffer, returning the first character of it.
 It also realises the SWI-Prolog timeout facility.
@@ -497,8 +518,11 @@ int
 S__fillbuf(IOSTREAM *s)
 { int c;
 
-  if ( s->flags & (SIO_FEOF|SIO_FERR) )
+  if ( s->flags & (SIO_FEOF|SIO_FERR) )	/* reading past eof */
-  { s->flags |= SIO_FEOF2;		/* reading past eof */
+  { if ( s->flags & SIO_FEOF2ERR )
+      s->flags |= (SIO_FEOF2|SIO_FERR);
+    else
+      s->flags |= SIO_FEOF2;
     return -1;
   }
 
@@ -508,7 +532,7 @@ S__fillbuf(IOSTREAM *s)
   if ( s->timeout >= 0 && !s->downstream )
   { int rc;
 
-    if ( (rc=Swait_for_data(s)) < 0 )
+    if ( (rc=S__wait(s)) < 0 )
       return rc;
   }
 #endif
@@ -517,7 +541,8 @@ S__fillbuf(IOSTREAM *s)
   { char chr;
     ssize_t n;
 
-    if ( (n=(*s->functions->read)(s->handle, &chr, 1)) == 1 )
+    n = (*s->functions->read)(s->handle, &chr, 1);
+    if ( n == 1 )
     { c = char_to_int(chr);
       return c;
     } else if ( n == 0 )
@@ -548,7 +573,8 @@ S__fillbuf(IOSTREAM *s)
       len = s->bufsize;
     }
 
-    if ( (n=(*s->functions->read)(s->handle, s->limitp, len)) > 0 )
+    n = (*s->functions->read)(s->handle, s->limitp, len);
+    if ( n > 0 )
     { s->limitp += n;
       c = char_to_int(*s->bufp++);
       return c;
@@ -777,7 +803,7 @@ put_code(int c, IOSTREAM *s)
       }
       goto simple;
     case ENC_ANSI:
-    { char b[MB_LEN_MAX];
+    { char b[PL_MB_LEN_MAX];
       size_t n;
 
       if ( !s->mbstate )
@@ -863,7 +889,10 @@ Sputcode(int c, IOSTREAM *s)
   if ( s->tee && s->tee->magic == SIO_MAGIC )
     Sputcode(c, s->tee);
 
-  if ( c == '\n' && (s->flags&SIO_TEXT) && s->newline == SIO_NL_DOS )
+  if ( c == '\n' &&
+       (s->flags&SIO_TEXT) &&
+       s->newline == SIO_NL_DOS &&
+       s->lastc != '\r' )
   { if ( put_code('\r', s) < 0 )
       return -1;
   }
@@ -886,7 +915,7 @@ Scanrepresent(int c, IOSTREAM *s)
       return -1;
     case ENC_ANSI:
     { mbstate_t state;
-      char b[MB_LEN_MAX];
+      char b[PL_MB_LEN_MAX];
 
       memset(&state, 0, sizeof(state));
       if ( wcrtomb(b, (wchar_t)c, &state) != (size_t)-1 )
@@ -1072,14 +1101,15 @@ returns \n, but it returns the same for a single \n.
 
 Often, we could keep track of bufp and reset this, but we must deal with
 the case where we fetch a new buffer. In this case, we must copy the few
-remaining bytes to the `unbuffer' area.
+remaining bytes to the `unbuffer' area. If SIO_USERBUF is set, we do not
+have this spare buffer space. This  is   used  for reading from strings,
+which cannot fetch a new buffer anyway.
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 int
 Speekcode(IOSTREAM *s)
 { int c;
   char *start;
-  IOPOS *psave = s->position;
   size_t safe = (size_t)-1;
 
   if ( !s->buffer )
@@ -1094,15 +1124,19 @@ Speekcode(IOSTREAM *s)
   if ( (s->flags & SIO_FEOF) )
     return -1;
 
-  if ( s->bufp + UNDO_SIZE > s->limitp )
+  if ( s->bufp + UNDO_SIZE > s->limitp && !(s->flags&SIO_USERBUF) )
   { safe = s->limitp - s->bufp;
     memcpy(s->buffer-safe, s->bufp, safe);
   }
 
   start = s->bufp;
-  s->position = NULL;
+  if ( s->position )
-  c = Sgetcode(s);
+  { IOPOS psave = *s->position;
-  s->position = psave;
+    c = Sgetcode(s);
+    *s->position = psave;
+  } else
+  { c = Sgetcode(s);
+  }
   if ( Sferror(s) )
     return -1;
 
@@ -1110,7 +1144,7 @@ Speekcode(IOSTREAM *s)
 
   if ( s->bufp > start )
   { s->bufp = start;
-  } else
+  } else if ( c != -1 )
   { assert(safe != (size_t)-1);
     s->bufp = s->buffer-safe;
   }
@@ -1341,10 +1375,6 @@ Sfeof(IOSTREAM *s)
     return -1;
   }
 
-  if ( s->downstream != NULL &&
-       Sfeof(s->downstream))
-    return TRUE;
-
   if ( S__fillbuf(s) == -1 )
     return TRUE;
 
@@ -1440,6 +1470,11 @@ Ssetenc(IOSTREAM *s, IOENC enc, IOENC *old)
   }
 
   s->encoding = enc;
+  if ( enc == ENC_OCTET )
+    s->flags &= ~SIO_TEXT;
+  else
+    s->flags |= SIO_TEXT;
+
   return 0;
 }
 
@@ -1490,23 +1525,23 @@ Sunit_size(IOSTREAM *s)
 Return the size of the underlying data object.  Should be optimized;
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
-long
+int64_t
 Ssize(IOSTREAM *s)
 { if ( s->functions->control )
-  { long size;
+  { int64_t size;
 
     if ( (*s->functions->control)(s->handle, SIO_GETSIZE, (void *)&size) == 0 )
       return size;
   }
   if ( s->functions->seek )
-  { long here = Stell(s);
+  { int64_t here = Stell64(s);
-    long end;
+    int64_t end;
 
-    if ( Sseek(s, 0, SIO_SEEK_END) == 0 )
+    if ( Sseek64(s, 0, SIO_SEEK_END) == 0 )
-      end = Stell(s);
+      end = Stell64(s);
     else
       end = -1;
-    Sseek(s, here, SIO_SEEK_SET);
+    Sseek64(s, here, SIO_SEEK_SET);
 
     return end;
   }
@@ -1667,13 +1702,13 @@ unallocStream(IOSTREAM *s)
 #ifdef O_PLMT
   if ( s->mutex )
   { recursiveMutexDelete(s->mutex);
-    free(s->mutex);
+    PL_free(s->mutex);
     s->mutex = NULL;
   }
 #endif
 
   if ( !(s->flags & SIO_STATIC) )
-    free(s);
+    PL_free(s);
 }
 
 
@@ -1711,7 +1746,7 @@ Sclose(IOSTREAM *s)
 #ifdef __WINDOWS__
   if ( (s->flags & SIO_ADVLOCK) )
   { OVERLAPPED ov;
-    HANDLE h = (HANDLE)_get_osfhandle((int)s->handle);
+    HANDLE h = (HANDLE)_get_osfhandle((int)((uintptr_t)s->handle));
 
     memset(&ov, 0, sizeof(ov));
     UnlockFileEx(h, 0, 0, 0xffffffff, &ov);
@@ -1732,9 +1767,9 @@ Sclose(IOSTREAM *s)
   if ( rval < 0 )
     reportStreamError(s);
   run_close_hooks(s);			/* deletes Prolog registration */
+  s->magic = SIO_CMAGIC;
   SUNLOCK(s);
 
-  s->magic = SIO_CMAGIC;
   if ( s->message )
     free(s->message);
   if ( s->references == 0 )
@@ -1845,11 +1880,23 @@ Svprintf(const char *fm, va_list args)
 }
 
 
-#define NEXTCHR(s, c)	if ( utf8 ) \
+#define NEXTCHR(s, c)				\
-			{ (s) = utf8_get_char((s), &(c)); \
+	switch (enc)				\
-			} else \
+	{ case ENC_ANSI:			\
-			{ c = *(s)++; c &= 0xff; \
+	    c = *(s)++; c &= 0xff;		\
-			}
+	    break;				\
+	  case ENC_UTF8:			\
+	    (s) = utf8_get_char((s), &(c));	\
+	    break;				\
+	  case ENC_WCHAR:			\
+	  { wchar_t *_w = (wchar_t*)(s);	\
+	    c = *_w++;				\
+	    (s) = (char*)_w;			\
+	    break;				\
+	  }					\
+	  default:				\
+	    break;				\
+	}
 
 #define OUTCHR(s, c)	do { printed++; \
 			     if ( Sputcode((c), (s)) < 0 ) goto error; \
@@ -1911,7 +1958,7 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
 	char fbuf[100], *fs = fbuf, *fe = fbuf;
 	int islong = 0;
 	int pad = ' ';
-	int utf8 = FALSE;
+	IOENC enc = ENC_ANSI;
 
 	for(;;)
 	{ switch(*fm)
@@ -1952,13 +1999,19 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
 	{ islong++;			/* 1: %ld */
 	  fm++;
 	}
-	if ( *fm == 'l' )
+	switch ( *fm )
-	{ islong++;			/* 2: %lld */
+	{ case 'l':
-	  fm++;
+	    islong++;			/* 2: %lld */
-	}
+	    fm++;
-	if ( *fm == 'U' )		/* %Us: UTF-8 string */
+	    break;
-	{ utf8 = TRUE;
+	  case 'U':			/* %Us: UTF-8 string */
-	  fm++;
+	    enc = ENC_UTF8;
+	    fm++;
+	    break;
+	  case 'W':			/* %Ws: wide string */
+	    enc = ENC_WCHAR;
+	    fm++;
+	    break;
 	}
 
 	switch(*fm)
@@ -1983,41 +2036,53 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
 	  case 'u':
 	  case 'x':
 	  case 'X':
-	  { intptr_t v = 0;			/* make compiler silent */
+	  { int      vi = 0;
-	    int64_t vl = 0;
+	    long     vl = 0;			/* make compiler silent */
+	    int64_t vll = 0;
 	    char fmbuf[8], *fp=fmbuf;
 
 	    switch( islong )
 	    { case 0:
-		v = va_arg(args, int);
+		vi = va_arg(args, int);
 	        break;
 	      case 1:
-		v = va_arg(args, long);
+		vl = va_arg(args, long);
 	        break;
 	      case 2:
-	        vl = va_arg(args, int64_t);
+	        vll = va_arg(args, int64_t);
 		break;
+	      default:
+		assert(0);
 	    }
 
 	    *fp++ = '%';
 	    if ( modified )
 	      *fp++ = '#';
-	    *fp++ = 'l';
+	    switch( islong )
-	    if ( islong < 2 )
+	    { case 0:
-	    { *fp++ = *fm;
+		*fp++ = *fm;
-	      *fp   = '\0';
+	        *fp   = '\0';
-	      SNPRINTF3(fmbuf, v);
+		SNPRINTF3(fmbuf, vi);
-	    } else
+		break;
-	    {
+	      case 1:
+		*fp++ = 'l';
+	        *fp++ = *fm;
+		*fp   = '\0';
+		SNPRINTF3(fmbuf, vl);
+		break;
+	      case 2:
 #ifdef __WINDOWS__
-	      strcat(fp-1, "I64");	/* Synchronise with INT64_FORMAT! */
+	        *fp++ = 'I';		/* Synchronise with INT64_FORMAT! */
-	      fp += strlen(fp);
+	        *fp++ = '6';
+		*fp++ = '4';
 #else
-	      *fp++ = 'l';
+	        *fp++ = 'l';
+	        *fp++ = 'l';
 #endif
-	      *fp++ = *fm;
+	        *fp++ = *fm;
-	      *fp   = '\0';
+	        *fp   = '\0';
-	      SNPRINTF3(fmbuf, vl);
+	        SNPRINTF3(fmbuf, vll);
+		break;
 	    }
 
 	    break;
@@ -2075,12 +2140,25 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
 	  { size_t w;
 
 	    if ( fs == fbuf )
-	      w = fe - fs;
+	    { w = fe - fs;
-	    else
+	    } else
-	      w = strlen(fs);
+	    { switch(enc)
-
+	      { case ENC_ANSI:
-	    if ( utf8 )
+		  w = strlen(fs);
-	      w = utf8_strlen(fs, w);
+		  break;
+		case ENC_UTF8:
+		  w = strlen(fs);
+		  w = utf8_strlen(fs, w);
+		  break;
+		case ENC_WCHAR:
+		  w = wcslen((wchar_t*)fs);
+		  break;
+		default:
+		  assert(0);
+		  w = 0;		/* make compiler happy */
+		  break;
+	      }
+	    }
 
 	    if ( (ssize_t)w < arg1 )
 	    { w = arg1 - w;
@@ -2609,7 +2687,7 @@ Scontrol_file(void *handle, int action, void *arg)
 
   switch(action)
   { case SIO_GETSIZE:
-    { intptr_t *rval = arg;
+    { int64_t *rval = arg;
       struct stat buf;
 
       if ( fstat(fd, &buf) == 0 )
@@ -2621,6 +2699,11 @@ Scontrol_file(void *handle, int action, void *arg)
     case SIO_SETENCODING:
     case SIO_FLUSHOUTPUT:
       return 0;
+    case SIO_GETFILENO:
+    { int *p = arg;
+      *p = fd;
+      return 0;
+    }
     default:
       return -1;
   }
@@ -2662,13 +2745,20 @@ provide  the  socket-id  through   Sfileno,    this   code   crashes  on
 tcp_open_socket(). As ttys and its detection is   of no value on Windows
 anyway, we skip this. Second, Windows doesn't have fork(), so FD_CLOEXEC
 is of no value.
+
+For now, we use PL_malloc_uncollectable(). In   the  end, this is really
+one of the object-types we want to leave to GC.
 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
+#ifndef FD_CLOEXEC			/* This is not defined in MacOS */
+#define FD_CLOEXEC 1
+#endif
+
 IOSTREAM *
 Snew(void *handle, int flags, IOFUNCTIONS *functions)
 { IOSTREAM *s;
 
-  if ( !(s = malloc(sizeof(IOSTREAM))) )
+  if ( !(s = PL_malloc_uncollectable(sizeof(IOSTREAM))) )
   { errno = ENOMEM;
     return NULL;
   }
@@ -2680,7 +2770,11 @@ Snew(void *handle, int flags, IOFUNCTIONS *functions)
   s->functions     = functions;
   s->timeout       = -1;		/* infinite */
   s->posbuf.lineno = 1;
-  s->encoding      = ENC_ISO_LATIN_1;
+  if ( (flags&SIO_TEXT) )
+  { s->encoding    = initEncoding();
+  } else
+  { s->encoding	   = ENC_OCTET;
+  }
 #if CRLF_MAPPING
   s->newline       = SIO_NL_DOS;
 #endif
@@ -2688,8 +2782,8 @@ Snew(void *handle, int flags, IOFUNCTIONS *functions)
     s->position = &s->posbuf;
 #ifdef O_PLMT
   if ( !(flags & SIO_NOMUTEX) )
-  { if ( !(s->mutex = malloc(sizeof(recursiveMutex))) )
+  { if ( !(s->mutex = PL_malloc(sizeof(recursiveMutex))) )
-    { free(s);
+    { PL_free(s);
       return NULL;
     }
     recursiveMutexInit(s->mutex);
@@ -2701,7 +2795,7 @@ Snew(void *handle, int flags, IOFUNCTIONS *functions)
   if ( (fd = Sfileno(s)) >= 0 )
   { if ( isatty(fd) )
       s->flags |= SIO_ISATTY;
-#if defined(F_SETFD) && defined(FD_CLOEXEC)
+#ifdef F_SETFD
     fcntl(fd, F_SETFD, FD_CLOEXEC);
 #endif
   }
@@ -2804,13 +2898,23 @@ Sopen_file(const char *path, const char *how)
     struct flock buf;
 
     memset(&buf, 0, sizeof(buf));
-    buf.l_type = (lock == lread ? F_RDLCK : F_WRLCK);
+    buf.l_whence = SEEK_SET;
+    buf.l_type   = (lock == lread ? F_RDLCK : F_WRLCK);
 
-    if ( fcntl(fd, wait ? F_SETLKW : F_SETLK, &buf) < 0 )
+    while( fcntl(fd, wait ? F_SETLKW : F_SETLK, &buf) != 0 )
-    { int save = errno;
+    { if ( errno == EINTR )
-      close(fd);
+      { if ( PL_handle_signals() < 0 )
-      errno = save;
+	{ close(fd);
-      return NULL;
+	  return NULL;
+	}
+	continue;
+      } else
+      { int save = errno;
+
+	close(fd);
+	errno = save;
+	return NULL;
+      }
     }
 #else					/* we don't have locking */
 #if __WINDOWS__
@@ -2891,12 +2995,10 @@ Sfileno(IOSTREAM *s)
   if ( s->flags & SIO_FILE )
   { intptr_t h = (intptr_t)s->handle;
     n = (int)h;
-  } else if ( s->flags & SIO_PIPE )
-  { n = fileno((FILE *)s->handle);
   } else if ( s->functions->control &&
 	      (*s->functions->control)(s->handle,
 				       SIO_GETFILENO,
-				       (void *)&n)  == 0 )
+				       (void *)&n) == 0 )
   { ;
   } else
   { errno = EINVAL;
@@ -2907,6 +3009,30 @@ Sfileno(IOSTREAM *s)
 }
 
 
+#ifdef __WINDOWS__
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+On  Windows,  type  SOCKET  is   an    unsigned   int   and  all  values
+[0..INVALID_SOCKET) are valid. It is  also   not  allowed  to run normal
+file-functions on it or the application will crash. There seems to be no
+way out except for introducing an extra function at this level :-(
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+SOCKET
+Swinsock(IOSTREAM *s)
+{ SOCKET n = INVALID_SOCKET;
+
+  if ( s->functions->control &&
+       (*s->functions->control)(s->handle,
+				SIO_GETWINSOCK,
+				(void *)&n) == 0 )
+  { return n;
+  }
+
+  errno = EINVAL;
+  return INVALID_SOCKET;
+}
+#endif
+
 		 /*******************************
 		 *	       PIPES		*
 		 *******************************/
@@ -2915,13 +3041,9 @@ Sfileno(IOSTREAM *s)
 #ifdef __WINDOWS__
 #include "windows/popen.c"
 
-#ifdef popen
 #undef popen
-#endif
-#define popen(cmd, how) pt_popen(cmd, how)
-#ifdef pclose
 #undef pclose
-#endif
+#define popen(cmd, how) pt_popen(cmd, how)
 #define pclose(fd)	pt_pclose(fd)
 #endif
 
@@ -2958,11 +3080,31 @@ Sclose_pipe(void *handle)
 }
 
 
+static int
+Scontrol_pipe(void *handle, int action, void *arg)
+{ FILE *fp = handle;
+
+  switch(action)
+  { case SIO_GETFILENO:
+    { int *ap = arg;
+      *ap = fileno(fp);
+      return 0;
+    }
+    case SIO_FLUSHOUTPUT:
+    case SIO_SETENCODING:
+      return 0;
+    default:
+      return -1;
+  }
+}
+
+
 IOFUNCTIONS Spipefunctions =
 { Sread_pipe,
   Swrite_pipe,
   (Sseek_function)0,
-  Sclose_pipe
+  Sclose_pipe,
+  Scontrol_pipe
 };
 
 
@@ -2983,9 +3125,9 @@ Sopen_pipe(const char *command, const char *type)
   { int flags;
 
     if ( *type == 'r' )
-      flags = SIO_PIPE|SIO_INPUT|SIO_FBUF;
+      flags = SIO_INPUT|SIO_FBUF;
     else
-      flags = SIO_PIPE|SIO_OUTPUT|SIO_FBUF;
+      flags = SIO_OUTPUT|SIO_FBUF;
 
     return Snew((void *)fd, flags, &Spipefunctions);
   }
@@ -3229,12 +3371,20 @@ Sopenmem(char **buffer, size_t *sizep, const char *mode)
 
 static ssize_t
 Sread_string(void *handle, char *buf, size_t size)
-{ return 0;				/* signal EOF */
+{ (void)handle;
+  (void)buf;
+  (void)size;
+
+  return 0;				/* signal EOF */
 }
 
 static ssize_t
 Swrite_string(void *handle, char *buf, size_t size)
-{ errno = ENOSPC;			/* signal error */
+{ (void)handle;
+  (void)buf;
+  (void)size;
+
+  errno = ENOSPC;			/* signal error */
   return -1;
 }
 
@@ -3267,7 +3417,7 @@ Sopen_string(IOSTREAM *s, char *buf, size_t size, const char *mode)
 { int flags = SIO_FBUF|SIO_USERBUF;
 
   if ( !s )
-  { if ( !(s = malloc(sizeof(IOSTREAM))) )
+  { if ( !(s = PL_malloc_uncollectable(sizeof(IOSTREAM))) ) /* TBD: Use GC */
     { errno = ENOMEM;
       return NULL;
     }
@@ -3310,7 +3460,7 @@ Sopen_string(IOSTREAM *s, char *buf, size_t size, const char *mode)
 
 #define STDIO(n, f) { NULL, NULL, NULL, NULL, \
 		      EOF, SIO_MAGIC, 0, f, {0, 0, 0}, NULL, \
-		      ((void *)(n)), &Sttyfunctions, \
+		      (void *)(n), &Sttyfunctions, \
 		      0, NULL, \
 		      (void (*)(void *))0, NULL, \
 		      -1, \
@@ -3321,7 +3471,7 @@ Sopen_string(IOSTREAM *s, char *buf, size_t size, const char *mode)
 #define SIO_STDIO (SIO_FILE|SIO_STATIC|SIO_NOCLOSE|SIO_ISATTY|SIO_TEXT)
 #define STDIO_STREAMS \
   STDIO(0, SIO_STDIO|SIO_LBUF|SIO_INPUT|SIO_NOFEOF),	/* Sinput */ \
-  STDIO(1, SIO_STDIO|SIO_LBUF|SIO_OUTPUT|SIO_REPPL), 	/* Soutput */ \
+  STDIO(1, SIO_STDIO|SIO_LBUF|SIO_OUTPUT|SIO_REPPL),	/* Soutput */ \
   STDIO(2, SIO_STDIO|SIO_NBUF|SIO_OUTPUT|SIO_REPPL)	/* Serror */
 
 
@@ -3335,31 +3485,33 @@ static const IOSTREAM S__iob0[] =
 };
 
 
-/* vsc: Scleanup should reset init done */
+static int S__initialised = FALSE;
-static int done;
 
 void
 SinitStreams(void)
-{
+{ if ( !S__initialised )
-
-  if ( !done++ )
   { int i;
-    IOENC enc = initEncoding();
+    IOENC enc;
+
+    S__initialised = TRUE;
+    enc = initEncoding();
 
     for(i=0; i<=2; i++)
-    { if ( !isatty(i) )
+    { IOSTREAM *s = &S__iob[i];
-      { S__iob[i].flags &= ~SIO_ISATTY;
+
-	S__iob[i].functions = &Sfilefunctions; /* Check for pipe? */
+      if ( !isatty(i) )
+      { s->flags &= ~SIO_ISATTY;
+	s->functions = &Sfilefunctions; /* Check for pipe? */
       }
-      if ( S__iob[i].encoding == ENC_ISO_LATIN_1 )
+      if ( s->encoding == ENC_ISO_LATIN_1 )
-	S__iob[i].encoding = enc;
+	s->encoding = enc;
 #ifdef O_PLMT
-      S__iob[i].mutex = malloc(sizeof(recursiveMutex));
+      s->mutex = PL_malloc(sizeof(recursiveMutex));
-      recursiveMutexInit(S__iob[i].mutex);
+      recursiveMutexInit(s->mutex);
 #endif
 #if CRLF_MAPPING
       _setmode(i, O_BINARY);
-      S__iob[i].newline = SIO_NL_DOS;
+      s->newline = SIO_NL_DOS;
 #endif
     }
 
@@ -3461,11 +3613,12 @@ Scleanup(void)
 
       S__iob[i].mutex = NULL;
       recursiveMutexDelete(m);
-      free(m);
+      PL_free(m);
     }
 #endif
 
     *s = S__iob0[i];			/* re-initialise */
   }
-  done = 0;
+
+  S__initialised = FALSE;
 }

os/pl-string.c

@@ -19,7 +19,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 #include "pl-incl.h"
@@ -34,45 +34,10 @@ String operations that are needed for the shared IO library.
 		 *	     ALLOCATION		*
 		 *******************************/
 
-#ifdef O_DEBUG
-#define CHAR_INUSE 0x42
-#define CHAR_FREED 0x41
-
 char *
 store_string(const char *s)
 { if ( s )
-  { GET_LD
+  { char *copy = (char *)allocHeapOrHalt(strlen(s)+1);
-    char *copy = (char *)allocHeap(strlen(s)+2);
-
-    *copy++ = CHAR_INUSE;
-    strcpy(copy, s);
-
-    return copy;
-  } else
-  { return NULL;
-  }
-}
-
-
-void
-remove_string(char *s)
-{ if ( s )
-  { GET_LD
-    assert(s[-1] == CHAR_INUSE);
-
-    s[-1] = CHAR_FREED;
-    freeHeap(s-1, strlen(s)+2);
-  }
-}
-
-#else /*O_DEBUG*/
-
-char *
-store_string(const char *s)
-{ if ( s )
-  { GET_LD
-
-    char *copy = (char *)allocHeap(strlen(s)+1);
 
     strcpy(copy, s);
     return copy;
@@ -85,14 +50,9 @@ store_string(const char *s)
 void
 remove_string(char *s)
 { if ( s )
-  { GET_LD
     freeHeap(s, strlen(s)+1);
-  }
 }
 
-#endif /*O_DEBUG*/
-
-
 		 /*******************************
 		 *	     NUMBERS		*
 		 *******************************/
@@ -239,13 +199,13 @@ int_mbscoll(const char *s1, const char *s2, int icase)
   if ( l1 < 1024 && (w1 = alloca(sizeof(wchar_t)*(l1+1))) )
   { ml1 = FALSE;
   } else
-  { w1 = PL_malloc(sizeof(wchar_t)*(l1+1));
+  { w1 = PL_malloc_atomic(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));
+  { w2 = PL_malloc_atomic(sizeof(wchar_t)*(l2+1));
     ml2 = TRUE;
   }
 

os/pl-string.h

@@ -19,7 +19,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 #ifndef PL_STRING_H_INCLUDED
@@ -27,7 +27,7 @@
 
 COMMON(char *) 		store_string(const char *s);
 COMMON(void) 		remove_string(char *s);
-COMMON(char) 		digitName(int n, int smll);
+COMMON(char) 		digitName(int n, int small);
 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);

os/pl-table.c

@@ -1,11 +1,10 @@
-/*  $Id$
+/*  Part of SWI-Prolog
-
-    Part of SWI-Prolog
 
     Author:        Jan Wielemaker
-    E-mail:        jan@swi.psy.uva.nl
+    E-mail:        J.Wielemaker@vu.nl
     WWW:           http://www.swi-prolog.org
-    Copyright (C): 1985-2002, University of Amsterdam
+    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
@@ -19,7 +18,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 /*#define O_DEBUG 1*/
@@ -41,35 +40,35 @@ 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  intptr_t  enumerators  are
+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
+automatically advanced to the next free  symbol. This, in general, makes
 the enumeration of hash-tables safe.
 
-TODO: abort should delete  any  pending   enumerators.  This  should  be
+TBD: Resizing hash-tables causes major  headaches for concurrent access.
-thread-local, as thread_exit/1 should do the same.
+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 void
+static Symbol *
-allocHTableEntries(Table ht)
+allocHTableEntries(int buckets)
-{ GET_LD
+{ size_t bytes = buckets * sizeof(Symbol);
-  int n;
   Symbol *p;
 
-  ht->entries = allocHeap(ht->buckets * sizeof(Symbol));
+  p = allocHeapOrHalt(bytes);
+  memset(p, 0, bytes);
 
-  for(n=0, p = &ht->entries[0]; n < ht->buckets; n++, p++)
+  return p;
-    *p = NULL;
 }
 
 
 Table
 newHTable(int buckets)
-{ GET_LD
+{ Table ht;
-  Table ht;
 
-  ht		  = allocHeap(sizeof(struct table));
+  ht		  = allocHeapOrHalt(sizeof(struct table));
   ht->buckets	  = (buckets & ~TABLE_MASK);
   ht->size	  = 0;
   ht->enumerators = NULL;
@@ -79,25 +78,24 @@ newHTable(int buckets)
   if ( (buckets & TABLE_UNLOCKED) )
     ht->mutex = NULL;
   else
-  { ht->mutex     = allocHeap(sizeof(simpleMutex));
+  { ht->mutex     = allocHeapOrHalt(sizeof(simpleMutex));
     simpleMutexInit(ht->mutex);
   }
 #endif
 
-  allocHTableEntries(ht);
+  ht->entries = allocHTableEntries(ht->buckets);
   return ht;
 }
 
 
 void
 destroyHTable(Table ht)
-{ GET_LD
+{
-
 #ifdef O_PLMT
   if ( ht->mutex )
   { simpleMutexDelete(ht->mutex);
     freeHeap(ht->mutex, sizeof(*ht->mutex));
-	ht->mutex = NULL;
+    ht->mutex = NULL;
   }
 #endif
 
@@ -107,19 +105,19 @@ destroyHTable(Table ht)
 }
 
 
-#if O_DEBUG || O_HASHSTAT
+#if O_DEBUG
-#define HASHSTAT(c) c
 static int lookups;
 static int cmps;
 
 void
 exitTables(int status, void *arg)
-{ Sdprintf("hashstat: Anonymous tables: %d lookups using %d compares\n",
+{ (void)status;
+  (void)arg;
+
+  Sdprintf("hashstat: Anonymous tables: %d lookups using %d compares\n",
 	   lookups, cmps);
 }
-#else
+#endif
-#define HASHSTAT(c)
-#endif /*O_DEBUG*/
 
 
 void
@@ -129,7 +127,7 @@ initTables(void)
   if ( !done )
   { done = TRUE;
 
-    HASHSTAT(PL_on_halt(exitTables, NULL));
+    DEBUG(MSG_HASH_STAT, PL_on_halt(exitTables, NULL));
   }
 }
 
@@ -138,9 +136,9 @@ Symbol
 lookupHTable(Table ht, void *name)
 { Symbol s = ht->entries[pointerHashValue(name, ht->buckets)];
 
-  HASHSTAT(lookups++);
+  DEBUG(MSG_HASH_STAT, lookups++);
   for( ; s; s = s->next)
-  { HASHSTAT(cmps++);
+  { DEBUG(MSG_HASH_STAT, cmps++);
     if ( s->name == name )
       return s;
   }
@@ -170,41 +168,75 @@ checkHTable(Table ht)
 /* MT: Locked by calling addHTable()
 */
 
-static void
+static Symbol
-rehashHTable(Table ht)
+rehashHTable(Table ht, Symbol map)
-{ GET_LD
+{ Symbol *newentries, *oldentries;
-  Symbol *oldtab;
+  int     newbuckets, oldbuckets;
-  int    oldbucks;
+  int     i;
-  int    i;
+  int     safe_copy = (ht->mutex != NULL);
 
-  oldtab   = ht->entries;
+  newbuckets = ht->buckets*2;
-  oldbucks = ht->buckets;
+  newentries = allocHTableEntries(newbuckets);
-  ht->buckets *= 2;
-  allocHTableEntries(ht);
 
-  DEBUG(1, Sdprintf("Rehashing table %p to %d entries\n", ht, ht->buckets));
+  DEBUG(MSG_HASH_STAT,
+	Sdprintf("Rehashing table %p to %d entries\n", ht, ht->buckets));
 
-  for(i=0; i<oldbucks; i++)
+  for(i=0; i<ht->buckets; i++)
   { Symbol s, n;
 
-    for(s=oldtab[i]; s; s = n)
+    if ( safe_copy )
-    { int v = (int)pointerHashValue(s->name, ht->buckets);
+    { for(s=ht->entries[i]; s; s = n)
+      { int v = (int)pointerHashValue(s->name, newbuckets);
+	Symbol s2 = allocHeapOrHalt(sizeof(*s2));
 
-      n = s->next;
+	n = s->next;
-      s->next = ht->entries[v];
+	if ( s == map )
-      ht->entries[v] = s;
+	  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;
+      }
     }
   }
 
-  freeHeap(oldtab, oldbucks * sizeof(Symbol));
+  oldentries  = ht->entries;
-  DEBUG(0, checkHTable(ht));
+  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)
-{ GET_LD
+{ Symbol s;
-  Symbol s;
   int v;
 
   LOCK_TABLE(ht);
@@ -213,7 +245,7 @@ addHTable(Table ht, void *name, void *value)
   { UNLOCK_TABLE(ht);
     return NULL;
   }
-  s = allocHeap(sizeof(struct symbol));
+  s = allocHeapOrHalt(sizeof(struct symbol));
   s->name  = name;
   s->value = value;
   s->next  = ht->entries[v];
@@ -223,7 +255,7 @@ addHTable(Table ht, void *name, void *value)
 		    ht, name, value, ht->size));
 
   if ( ht->buckets * 2 < ht->size && !ht->enumerators )
-    rehashHTable(ht);
+    s = rehashHTable(ht, s);
   UNLOCK_TABLE(ht);
 
   DEBUG(1, checkHTable(ht));
@@ -237,8 +269,7 @@ Note: s must be in the table!
 
 void
 deleteSymbolHTable(Table ht, Symbol s)
-{ GET_LD
+{ int v;
-  int v;
   Symbol *h;
   TableEnum e;
 
@@ -255,6 +286,9 @@ deleteSymbolHTable(Table ht, Symbol s)
   { if ( *h == s )
     { *h = (*h)->next;
 
+      s->next = NULL;				/* force crash */
+      s->name = NULL;
+      s->value = NULL;
       freeHeap(s, sizeof(struct symbol));
       ht->size--;
 
@@ -268,8 +302,7 @@ deleteSymbolHTable(Table ht, Symbol s)
 
 void
 clearHTable(Table ht)
-{ GET_LD
+{ int n;
-  int n;
   TableEnum e;
 
   LOCK_TABLE(ht);
@@ -309,24 +342,23 @@ Table copyHTable(Table org)
 
 Table
 copyHTable(Table org)
-{ GET_LD
+{ Table ht;
-  Table ht;
   int n;
 
-  ht = allocHeap(sizeof(struct table));
+  ht = allocHeapOrHalt(sizeof(struct table));
   LOCK_TABLE(org);
   *ht = *org;				/* copy all attributes */
 #ifdef O_PLMT
   ht->mutex = NULL;
 #endif
-  allocHTableEntries(ht);
+  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 = allocHeap(sizeof(*s2));
+    { Symbol s2 = allocHeapOrHalt(sizeof(*s2));
 
       *q = s2;
       q = &s2->next;
@@ -340,7 +372,7 @@ copyHTable(Table org)
   }
 #ifdef O_PLMT
   if ( org->mutex )
-  { ht->mutex = allocHeap(sizeof(simpleMutex));
+  { ht->mutex = allocHeapOrHalt(sizeof(simpleMutex));
     simpleMutexInit(ht->mutex);
   }
 #endif
@@ -356,8 +388,7 @@ copyHTable(Table org)
 
 TableEnum
 newTableEnum(Table ht)
-{ GET_LD
+{ TableEnum e = allocHeapOrHalt(sizeof(struct table_enum));
-  TableEnum e = allocHeap(sizeof(struct table_enum));
   Symbol n;
 
   LOCK_TABLE(ht);
@@ -378,8 +409,7 @@ newTableEnum(Table ht)
 
 void
 freeTableEnum(TableEnum e)
-{ GET_LD
+{ TableEnum *ep;
-  TableEnum *ep;
   Table ht;
 
   if ( !e )

os/pl-utf8.c

@@ -19,7 +19,7 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 #include <string.h>			/* get size_t */

os/pl-utf8.h

@@ -19,13 +19,15 @@
 
     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
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 */
 
 
 #ifndef UTF8_H_INCLUDED
 #define UTF8_H_INCLUDED
 
+#define PL_MB_LEN_MAX 16
+
 #define UTF8_MALFORMED_REPLACEMENT 0xfffd
 
 #define ISUTF8_MB(c) ((unsigned)(c) >= 0xc0 && (unsigned)(c) <= 0xfd)