Merge trunk.

Implementation looks complete. Still missing: test-cases and documentation.

18 files changed, 109 insertions, 76 deletions

diff --git a/generic/regc_lex.c b/generic/regc_lex.c
index affcb48..4c8f15f 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -457,7 +457,7 @@ next(
 	    if (ATEOS()) {
 		FAILW(REG_EESCAPE);
 	    }
-	    (DISCARD)lexescape(v);
+	    (void)lexescape(v);
 	    switch (v->nexttype) {	/* not all escapes okay here */
 	    case PLAIN:
 		return 1;
@@ -716,7 +716,7 @@ next(
 	}
 	RETV(PLAIN, *v->now++);
     }
-    (DISCARD)lexescape(v);
+    (void)lexescape(v);
     if (ISERR()) {
 	FAILW(REG_EESCAPE);
     }
@@ -1143,7 +1143,7 @@ skip(
 /*
  - newline - return the chr for a newline
  * This helps confine use of CHR to this source file.
- ^ static chr newline(NOPARMS);
+ ^ static chr newline(void);
  */
 static chr
 newline(void)
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index a6958fe..ab3b7f1 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -1227,7 +1227,7 @@ cmp(
     const chr *x, const chr *y,	/* strings to compare */
     size_t len)			/* exact length of comparison */
 {
-    return memcmp(VS(x), VS(y), len*sizeof(chr));
+    return memcmp((void*)(x), (void*)(y), len*sizeof(chr));
 }
 
 /*
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 088c6c0..240fcfe 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -843,7 +843,7 @@ moveins(
 
 /*
  - copyins - copy in arcs of a state to another state
- ^ static VOID copyins(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyins(struct nfa *, struct state *, struct state *, int);
  */
 static void
 copyins(
@@ -1100,7 +1100,7 @@ moveouts(
 
 /*
  - copyouts - copy out arcs of a state to another state
- ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyouts(struct nfa *, struct state *, struct state *, int);
  */
 static void
 copyouts(
diff --git a/generic/regcomp.c b/generic/regcomp.c
index 211cd70..58d55fb 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -82,7 +82,7 @@ static int lexescape(struct vars *);
 static int lexdigits(struct vars *, int, int, int);
 static int brenext(struct vars *, pchr);
 static void skip(struct vars *);
-static chr newline(NOPARMS);
+static chr newline(void);
 static chr chrnamed(struct vars *, const chr *, const chr *, pchr);
 /* === regc_color.c === */
 static void initcm(struct vars *, struct colormap *);
@@ -341,13 +341,13 @@ compile(
     re->re_info = 0;		/* bits get set during parse */
     re->re_csize = sizeof(chr);
     re->re_guts = NULL;
-    re->re_fns = VS(&functions);
+    re->re_fns = (void*)(&functions);
 
     /*
      * More complex setup, malloced things.
      */
 
-    re->re_guts = VS(MALLOC(sizeof(struct guts)));
+    re->re_guts = (void*)(MALLOC(sizeof(struct guts)));
     if (re->re_guts == NULL) {
 	return freev(v, REG_ESPACE);
     }
@@ -434,7 +434,7 @@ compile(
      * Can sacrifice main NFA now, so use it as work area.
      */
 
-    (DISCARD) optimize(v->nfa, debug);
+    (void) optimize(v->nfa, debug);
     CNOERR();
     makesearch(v, v->nfa);
     CNOERR();
@@ -1920,10 +1920,10 @@ nfatree(
     assert(t != NULL && t->begin != NULL);
 
     if (t->left != NULL) {
-	(DISCARD) nfatree(v, t->left, f);
+	(void) nfatree(v, t->left, f);
     }
     if (t->right != NULL) {
-	(DISCARD) nfatree(v, t->right, f);
+	(void) nfatree(v, t->right, f);
     }
 
     return nfanode(v, t, f);
diff --git a/generic/regcustom.h b/generic/regcustom.h
index 681b97d..1f00bf4 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -37,9 +37,9 @@
  */
 
 #define	FUNCPTR(name, args)	(*name)args
-#define	MALLOC(n)		VS(attemptckalloc(n))
-#define	FREE(p)			ckfree(VS(p))
-#define	REALLOC(p,n)		VS(attemptckrealloc(VS(p),n))
+#define	MALLOC(n)		(void*)(attemptckalloc(n))
+#define	FREE(p)			ckfree((void*)(p))
+#define	REALLOC(p,n)		(void*)(attemptckrealloc((void*)(p),n))
 
 /*
  * Do not insert extras between the "begin" and "end" lines - this chunk is
diff --git a/generic/regexec.c b/generic/regexec.c
index 6d12827..128d439 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -44,7 +44,7 @@ struct sset {			/* state set */
     unsigned hash;		/* hash of bitvector */
 #define	HASH(bv, nw)	(((nw) == 1) ? *(bv) : hash(bv, nw))
 #define	HIT(h,bv,ss,nw)	((ss)->hash == (h) && ((nw) == 1 || \
-	memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0))
+	memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0))
     int flags;
 #define	STARTER		01	/* the initial state set */
 #define	POSTSTATE	02	/* includes the goal state */
@@ -268,7 +268,7 @@ exec(
     if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
 	zapallsubs(pmatch, nmatch);
 	n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
-	memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
+	memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t));
     }
 
     /*
diff --git a/generic/regguts.h b/generic/regguts.h
index 1ac2465..9461136 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -49,23 +49,6 @@
 #include <assert.h>
 #endif
 
-/* voids */
-#ifndef VOID
-#define	VOID	void		/* for function return values */
-#endif
-#ifndef DISCARD
-#define	DISCARD	void		/* for throwing values away */
-#endif
-#ifndef PVOID
-#define	PVOID	void *		/* generic pointer */
-#endif
-#ifndef VS
-#define	VS(x)	((void*)(x))	/* cast something to generic ptr */
-#endif
-#ifndef NOPARMS
-#define	NOPARMS	void		/* for empty parm lists */
-#endif
-
 /* function-pointer declarator */
 #ifndef FUNCPTR
 #if __STDC__ >= 1
@@ -80,10 +63,10 @@
 #define	MALLOC(n)	malloc(n)
 #endif
 #ifndef REALLOC
-#define	REALLOC(p, n)	realloc(VS(p), n)
+#define	REALLOC(p, n)	realloc(p, n)
 #endif
 #ifndef FREE
-#define	FREE(p)		free(VS(p))
+#define	FREE(p)		free(p)
 #endif
 
 /* want size of a char in bits, and max value in bounded quantifiers */
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 73bd36f..cca4069 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1717,19 +1717,27 @@ InfoLoadedCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    const char *interpName;
+    const char *interpName, *packageName;
 
-    if ((objc != 1) && (objc != 2)) {
-	Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+    if (objc > 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?");
 	return TCL_ERROR;
     }
 
-    if (objc == 1) {		/* Get loaded pkgs in all interpreters. */
+    if (objc < 2) {		/* Get loaded pkgs in all interpreters. */
 	interpName = NULL;
     } else {			/* Get pkgs just in specified interp. */
 	interpName = TclGetString(objv[1]);
+	if (!interpName[0]) {
+	    interpName = NULL;
+	}
+    }
+    if (objc < 3) {		/* Get loaded files in all packages. */
+	packageName = NULL;
+    } else {			/* Get pkgs just in specified interp. */
+	packageName = TclGetString(objv[2]);
     }
-    return TclGetLoadedPackages(interp, interpName);
+    return TclGetLoadedPackages(interp, interpName, packageName);
 }
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 023c671..ed3d9a5 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1009,7 +1009,6 @@ TclNRSourceObjCmd(
 	}
 	encodingName = TclGetString(objv[2]);
     }
-
     return TclNREvalFile(interp, fileName, encodingName);
 }
 
diff --git a/generic/tclHash.c b/generic/tclHash.c
index ac9d40e..78ad514 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -924,7 +924,7 @@ HashStringKey(
  *
  * BogusFind --
  *
- *	This function is invoked when an Tcl_FindHashEntry is called on a
+ *	This function is invoked when Tcl_FindHashEntry is called on a
  *	table that has been deleted.
  *
  * Results:
@@ -951,7 +951,7 @@ BogusFind(
  *
  * BogusCreate --
  *
- *	This function is invoked when an Tcl_CreateHashEntry is called on a
+ *	This function is invoked when Tcl_CreateHashEntry is called on a
  *	table that has been deleted.
  *
  * Results:
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index e3a6b2a..de5d62d 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1890,6 +1890,7 @@ TclNREvalFile(
 		Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
 	return TCL_ERROR;
     }
+    TclPkgFileSeen(interp, Tcl_GetString(pathPtr));
 
     /*
      * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 8314925..5730624 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -165,7 +165,7 @@ declare 34 {
 #    int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
 #}
 declare 37 {
-    int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
+    int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName, const char *packageName)
 }
 declare 38 {
     int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index dfa5727..7f853b2 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -135,7 +135,8 @@ EXTERN int		TclGetIntForIndex(Tcl_Interp *interp,
 /* Slot 36 is reserved */
 /* 37 */
 EXTERN int		TclGetLoadedPackages(Tcl_Interp *interp,
-				const char *targetName);
+				const char *targetName,
+				const char *packageName);
 /* 38 */
 EXTERN int		TclGetNamespaceForQualName(Tcl_Interp *interp,
 				const char *qualName, Namespace *cxtNsPtr,
@@ -659,7 +660,7 @@ typedef struct TclIntStubs {
     int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
     void (*reserved35)(void);
     void (*reserved36)(void);
-    int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
+    int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName, const char *packageName); /* 37 */
     int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
     TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
     int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 184c158..2d8ed5f 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -397,12 +397,6 @@ Tcl_LoadObjCmd(
 	    goto done;
 	}
 
-	if (target == interp) {
-	    /* Only register the file if the load is done in the
-	     * current interpreter */
-	    TclPkgFileSeen(target, Tcl_GetString(objv[1]));
-	}
-
 	/*
 	 * Create a new record to describe this package.
 	 */
@@ -1040,10 +1034,13 @@ int
 TclGetLoadedPackages(
     Tcl_Interp *interp,		/* Interpreter in which to return information
 				 * or error message. */
-    const char *targetName)	/* Name of target interpreter or NULL. If
+    const char *targetName,	/* Name of target interpreter or NULL. If
 				 * NULL, return info about all interps;
 				 * otherwise, just return info about this
 				 * interpreter. */
+    const char *packageName)	/* Package name or NULL. If NULL, return info
+				 * all packages.
+				 */
 {
     Tcl_Interp *target;
     LoadedPackage *pkgPtr;
@@ -1054,6 +1051,22 @@ TclGetLoadedPackages(
 	/*
 	 * Return information about all of the available packages.
 	 */
+	if (packageName) {
+	    resultObj = NULL;
+	    Tcl_MutexLock(&packageMutex);
+	    for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
+		    pkgPtr = pkgPtr->nextPtr) {
+		if (!strcmp(packageName, pkgPtr->packageName)) {
+		    resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1);
+		    break;
+		}
+	    }
+	    Tcl_MutexUnlock(&packageMutex);
+	    if (resultObj) {
+		Tcl_SetObjResult(interp, resultObj);
+	    }
+	    return TCL_OK;
+	}
 
 	resultObj = Tcl_NewObj();
 	Tcl_MutexLock(&packageMutex);
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 3d052a6..c258987 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -204,12 +204,20 @@ static void PkgFilesCleanupProc(ClientData clientData,
     			    Tcl_Interp *interp)
 {
     PkgFiles *pkgFiles = (PkgFiles *) clientData;
+    Tcl_HashSearch search;
+    Tcl_HashEntry *entry;
 
     while (pkgFiles->names) {
 	PkgName *name = pkgFiles->names;
 	pkgFiles->names = name->nextPtr;
 	ckfree(name);
     }
+    entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
+    while (entry) {
+	Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
+	Tcl_DecrRefCount(obj);
+	entry = Tcl_NextHashEntry(&search);
+    }
     Tcl_DeleteHashTable(&pkgFiles->table);
     return;
 }
@@ -217,9 +225,20 @@ static void PkgFilesCleanupProc(ClientData clientData,
 void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName)
 {
     PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
-    if (pkgFiles) {
+    if (pkgFiles && pkgFiles->names) {
 	const char *name = pkgFiles->names->name;
-	printf("Seen %s for package %s\n", fileName, name);
+	Tcl_HashTable *table = &pkgFiles->table;
+	int new;
+	Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new);
+	Tcl_Obj *obj = Tcl_NewStringObj(fileName, -1);
+
+	if (new) {
+	    Tcl_SetHashValue(entry, obj);
+	    Tcl_IncrRefCount(obj);
+	} else {
+	    Tcl_Obj *list = Tcl_GetHashValue(entry);
+	    Tcl_ListObjAppendElement(interp, list, obj);
+	}
     }
 }
 
@@ -848,24 +867,19 @@ Tcl_PackageObjCmd(
     }
     switch ((enum pkgOptions) optionIndex) {
     case PKG_FILES: {
-	const char *keyString;
-	Tcl_Obj *result = Tcl_NewObj();
+	PkgFiles *pkgFiles;
 
-	for (i = 2; i < objc; i++) {
-	    keyString = TclGetString(objv[i]);
-	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
-	    if (hPtr == NULL) {
-		continue;
-	    }
-	    pkgPtr = Tcl_GetHashValue(hPtr);
-	    availPtr = pkgPtr->availPtr;
-	    while (availPtr != NULL) {
-		Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(availPtr->script, -1));
-		availPtr = availPtr->nextPtr;
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "package");
+	    return TCL_ERROR;
+	}
+	pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+	if (pkgFiles) {
+	    Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2]));
+	    if (entry) {
+		Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
 	    }
-	    ckfree(pkgPtr);
 	}
-	Tcl_SetObjResult(interp, result);
 	break;
     }
     case PKG_FORGET: {
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index ea25d4b..eb23f72 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -502,9 +502,16 @@ Tcl_RegExpMatchObj(
 {
     Tcl_RegExp re;
 
-    re = Tcl_GetRegExpFromObj(interp, patternObj,
-	    TCL_REG_ADVANCED | TCL_REG_NOSUB);
-    if (re == NULL) {
+    /*
+     * For performance reasons, first try compiling the RE without support for
+     * subexpressions. On failure, try again without TCL_REG_NOSUB in case the
+     * RE has backreferences in it. Closely related to [Bug 1366683]. If this
+     * still fails, an error message will be left in the interpreter.
+     */
+
+    if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
+	    TCL_REG_ADVANCED | TCL_REG_NOSUB))
+     && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) {
 	return -1;
     }
     return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
diff --git a/tests/info.test b/tests/info.test
index a6a5919..fd89b47 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -397,8 +397,8 @@ test info-10.3 {info library option} -body {
 set tcl_library $savedLibrary; unset savedLibrary
 
 test info-11.1 {info loaded option} -body {
-    info loaded a b
-} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"}
+    info loaded a b c
+} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"}
 test info-11.2 {info loaded option} -body {
     info loaded {}; info loaded gorp
 } -returnCodes error -result {could not find interpreter "gorp"}
diff --git a/tests/set-old.test b/tests/set-old.test
index 93169f1..309abaf 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -652,6 +652,13 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} {
     set a(11) 1
     list [catch {lsort [array names a -regexp ^1]} msg] $msg
 } {0 {1*2 11 12}}
+test set-old-8.52.1 {array command, array names -regexp, backrefs} {
+    catch {unset a}
+    set a(1*2) 1
+    set a(12) 1
+    set a(11) 1
+    list [catch {lsort [array names a -regexp {^(.)\1}]} msg] $msg
+} {0 11}
 test set-old-8.53 {array command, array names -regexp} {
     catch {unset a}
     set a(-glob) 1