SWI update

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);

H/pl-incl.h

@@ -468,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 */
@@ -540,6 +537,7 @@ typedef enum
 
 #define SYSTEM_MODE         (LD->prolog_flag.access_level == ACCESS_LEVEL_SYSTEM)
 
+#define PL_malloc_atomic malloc
 
 /* vsc: global variables */
 #include "pl-global.h"
@@ -702,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, */
@@ -911,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);
 

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-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
 */
 
 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -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,32 +319,21 @@ 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)) )
-    }
-#endif    
-    { 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);
@@ -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,15 +443,19 @@ 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] != '/' )
 		  path[plen++] = '/';
 		strcpy(&path[plen], prefix);
@@ -457,6 +463,7 @@ expand(const char *pattern, GlobInfo info)
 		  add_path(path, info);
 	      }
 	    }
+	  }
 	  succeed;
 	case '[':				/* meta characters: expand */
 	case '{':
@@ -489,6 +496,7 @@ 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 */
       fail;
@@ -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,14 +533,13 @@ 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, path);
 	      strcpy(&newp[plen], e->d_name);
-/*	    if ( !tail[0] || ExistsDirectory(newp) )
-	    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-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);
     }
 
-  *flagp &= ~(UNKNOWN_MASK);
+    if ( !SYSTEM_MODE )
-  *flagp |= flags;
+      printMessage(ATOM_warning, PL_CHARS, "unknown_in_module_user");
+  }
+
+  m->flags = 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);
   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);
+  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-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,10 +135,6 @@ 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, ...);
@@ -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 )
+  { IOPOS psave = *s->position;
     c = Sgetcode(s);
-  s->position = psave;
+    *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,10 +1880,22 @@ 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++; \
@@ -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':
+	    islong++;			/* 2: %lld */
 	    fm++;
-	}
+	    break;
-	if ( *fm == 'U' )		/* %Us: UTF-8 string */
+	  case 'U':			/* %Us: UTF-8 string */
-	{ utf8 = TRUE;
+	    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';
-	      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';
 #endif
 	        *fp++ = *fm;
 	        *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
+	    { switch(enc)
+	      { case ENC_ANSI:
+		  w = strlen(fs);
+		  break;
+		case ENC_UTF8:
 		  w = strlen(fs);
-
-	    if ( utf8 )
 		  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,14 +2898,24 @@ Sopen_file(const char *path, const char *how)
     struct flock buf;
 
     memset(&buf, 0, sizeof(buf));
+    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 )
+    { if ( errno == EINTR )
+      { if ( PL_handle_signals() < 0 )
+	{ close(fd);
+	  return NULL;
+	}
+	continue;
+      } else
       { int save = errno;
+
 	close(fd);
 	errno = save;
 	return NULL;
       }
+    }
 #else					/* we don't have locking */
 #if __WINDOWS__
     HANDLE h = (HANDLE)_get_osfhandle(fd);
@@ -2891,8 +2995,6 @@ 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,
@@ -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, \
@@ -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,13 +50,8 @@ 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
 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,20 +78,19 @@ 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);
@@ -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     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;
-      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 */