Merge tip-468 branch

9 files changed, 461 insertions, 25 deletions

diff --git a/tools/fix_tommath_h.tcl b/tools/fix_tommath_h.tcl
index 04bf857..cee29fa 100755
--- a/tools/fix_tommath_h.tcl
+++ b/tools/fix_tommath_h.tcl
@@ -22,7 +22,6 @@ foreach line [split $data \n] {
 	    {#define BN_H_} {
 		puts $line
 		puts {}
-		puts "\#include \"tclInt.h\""
 		puts "\#include \"tclTomMathDecls.h\""
 		puts "\#ifndef MODULE_SCOPE"
 		puts "\#define MODULE_SCOPE extern"
@@ -46,6 +45,12 @@ foreach line [split $data \n] {
 		puts "\#define MP_DIGIT_DECLARED"
 		puts "\#endif"
 	    }
+	    {typedef.*mp_word;} {
+		puts "\#ifndef MP_WORD_DECLARED"
+		puts $line
+		puts "\#define MP_WORD_DECLARED"
+		puts "\#endif"
+	    }
 	    {typedef struct} {
 		puts "\#ifndef MP_INT_DECLARED"
 		puts "\#define MP_INT_DECLARED"
@@ -73,10 +78,6 @@ foreach line [split $data \n] {
 		puts "\#if 0 /* these are macros in tclTomMathDecls.h */"
 		set eat_endif 1
 	    }
-	    {__x86_64__} {
-		puts "[string map {__x86_64__ NEVER} $line]\
-                      /* 128-bit ints fail in too many places */"
-	    }
 	    {#include} {
 		# remove all includes
 	    }
diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl
index 742aa46..f2f410f 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -191,19 +191,28 @@ proc genStubs::declare {args} {
     regsub -all "\[ \t\n\]+" [string trim $decl] " " decl
     set decl [parseDecl $decl]
 
-    foreach platform $platformList {
-	if {$decl ne ""} {
-	    set stubs($curName,$platform,$index) $decl
-	    if {![info exists stubs($curName,$platform,lastNum)] \
-		    || ($index > $stubs($curName,$platform,lastNum))} {
-		set stubs($curName,$platform,lastNum) $index
-	    }
+    if {([lindex $platformList 0] eq "deprecated")} {
+	set stubs($curName,deprecated,$index) [lindex $platformList 1]
+	set stubs($curName,generic,$index) $decl
+	if {![info exists stubs($curName,generic,lastNum)] \
+		|| ($index > $stubs($curName,generic,lastNum))} {
+	    set stubs($curName,generic,lastNum) $index
+	}
+    } elseif {([lindex $platformList 0] eq "nostub")} {
+	set stubs($curName,nostub,$index) [lindex $platformList 1]
+	set stubs($curName,generic,$index) $decl
+	if {![info exists stubs($curName,generic,lastNum)] \
+		|| ($index > $stubs($curName,generic,lastNum))} {
+	    set stubs($curName,generic,lastNum) $index
 	}
-	if {$platformList eq "deprecated"} {
-	    set stubs($curName,generic,$index) $decl
-	    if {![info exists stubs($curName,generic,lastNum)] \
-		    || ($index > $stubs($curName,generic,lastNum))} {
-		set stubs($curName,$platform,lastNum) $index
+    } else {
+	foreach platform $platformList {
+	    if {$decl ne ""} {
+		set stubs($curName,$platform,$index) $decl
+		    if {![info exists stubs($curName,$platform,lastNum)] \
+			    || ($index > $stubs($curName,$platform,lastNum))} {
+			set stubs($curName,$platform,lastNum) $index
+		}
 	    }
 	}
     }
@@ -468,9 +477,10 @@ proc genStubs::makeDecl {name decl index} {
 
     append text "/* $index */\n"
     if {[info exists stubs($name,deprecated,$index)]} {
-    set line "[string toupper $libraryName]_DEPRECATED $rtype"
+	append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n"
+	set line "$rtype"
     } else {
-    set line "$scspec $rtype"
+	set line "$scspec $rtype"
     }
     set count [expr {2 - ([string length $line] / 8)}]
     append line [string range "\t\t\t" 0 $count]
@@ -582,11 +592,17 @@ proc genStubs::makeMacro {name decl index} {
 
 proc genStubs::makeSlot {name decl index} {
     lassign $decl rtype fname args
+    variable stubs
 
     set lfname [string tolower [string index $fname 0]]
     append lfname [string range $fname 1 end]
 
     set text "    "
+    if {[info exists stubs($name,deprecated,$index)]} {
+	append text "TCL_DEPRECATED_API(\"$stubs($name,deprecated,$index)\") "
+    } elseif {[info exists stubs($name,nostub,$index)]} {
+	append text "TCL_DEPRECATED_API(\"$stubs($name,nostub,$index)\") "
+    }
     if {$args eq ""} {
 	append text $rtype " *" $lfname "; /* $index */\n"
 	return $text
@@ -698,6 +714,9 @@ proc genStubs::forAllStubs {name slotProc onAll textVar
 	    if {[info exists stubs($name,deprecated,$i)]} {
 		append text [$slotProc $name $stubs($name,generic,$i) $i]
 		set emit 1
+	    } elseif {[info exists stubs($name,nostub,$i)]} {
+		append text [$slotProc $name $stubs($name,generic,$i) $i]
+		set emit 1
 	    } elseif {[info exists stubs($name,generic,$i)]} {
 		if {[llength $slots] > 1} {
 		    puts stderr "conflicting generic and platform entries:\
diff --git a/tools/loadICU.tcl b/tools/loadICU.tcl
index 31f1e54..43d7e6a 100755
--- a/tools/loadICU.tcl
+++ b/tools/loadICU.tcl
@@ -27,6 +27,9 @@
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #----------------------------------------------------------------------
 
+puts stdout "TODO: output in UTF-8 in stead of using \\uhhhh sequences"
+exit; # Remove those two lines after modifying this tool.
+
 # Calculate the Chinese numerals from zero to ninety-nine.
 
 set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
new file mode 100644
index 0000000..e9b7ed1
--- /dev/null
+++ b/tools/makeHeader.tcl
@@ -0,0 +1,182 @@
+# makeHeader.tcl --
+#
+#	This script generates embeddable C source (in a .h file) from a .tcl
+#	script.
+#
+# Copyright (c) 2018 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.6
+
+namespace eval makeHeader {
+
+    ####################################################################
+    #
+    # mapSpecial --
+    #	Transform a single line so that it is able to be put in a C string.
+    #
+    proc mapSpecial {str} {
+	# All Tcl metacharacters and key C backslash sequences
+	set MAP {
+	    \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
+	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
+	}
+	set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
+
+	subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM]
+    }
+
+    ####################################################################
+    #
+    # compactLeadingSpaces --
+    #	Converts the leading whitespace on a line into a more compact form.
+    #
+    proc compactLeadingSpaces {line} {
+	set line [string map {\t {        }} [string trimright $line]]
+	if {[regexp {^[ ]+} $line spaces]} {
+	    regsub -all {[ ]{4}} $spaces \t replace
+	    set len [expr {[string length $spaces] - 1}]
+	    set line [string replace $line 0 $len $replace]
+	}
+	return $line
+    }
+
+    ####################################################################
+    #
+    # processScript --
+    #	Transform a whole sequence of lines with [mapSpecial].
+    #
+    proc processScript {scriptLines} {
+	lmap line $scriptLines {
+	    # Skip blank and comment lines; they're there in the original
+	    # sources so we don't need to copy them over.
+	    if {[regexp {^\s*(?:#|$)} $line]} continue
+	    format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
+	}
+    }
+
+    ####################################################################
+    #
+    # updateTemplate --
+    #	Rewrite a template to contain the content from the input script.
+    #
+    proc updateTemplate {dataVar scriptLines} {
+	set BEGIN "*!BEGIN!: Do not edit below this line.*"
+	set END "*!END!: Do not edit above this line.*"
+
+	upvar 1 $dataVar data
+
+	set from [lsearch -glob $data $BEGIN]
+	set to [lsearch -glob $data $END]
+	if {$from == -1 || $to == -1 || $from >= $to} {
+	    throw BAD "not a template"
+	}
+
+	set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]]
+    }
+
+    ####################################################################
+    #
+    # stripSurround --
+    #	Removes the header and footer comments from a (line-split list of
+    #	lines of) Tcl script code.
+    #
+    proc stripSurround {lines} {
+	set RE {^\s*$|^#}
+	set state 0
+	set lines [lmap line [lreverse $lines] {
+	    if {!$state && [regexp $RE $line]} continue {
+		set state 1
+		set line
+	    }
+	}]
+	return [lmap line [lreverse $lines] {
+	    if {$state && [regexp $RE $line]} continue {
+		set state 0
+		set line
+	    }
+	}]
+    }
+
+    ####################################################################
+    #
+    # updateTemplateFile --
+    #	Rewrites a template file with the lines of the given script.
+    #
+    proc updateTemplateFile {headerFile scriptLines} {
+	set f [open $headerFile "r+"]
+	try {
+	    set content [split [chan read -nonewline $f] "\n"]
+	    updateTemplate content [stripSurround $scriptLines]
+	    chan seek $f 0
+	    chan puts $f [join $content \n]
+	    chan truncate $f
+	} trap BAD msg {
+	    # Add the filename to the message
+	    throw BAD "${headerFile}: $msg"
+	} finally {
+	    chan close $f
+	}
+    }
+
+    ####################################################################
+    #
+    # readScript --
+    #	Read a script from a file and return its lines.
+    #
+    proc readScript {script} {
+	set f [open $script]
+	try {
+	    chan configure $f -encoding utf-8
+	    return [split [string trim [chan read $f]] "\n"]
+	} finally {
+	    chan close $f
+	}
+    }
+
+    ####################################################################
+    #
+    # run --
+    #	The main program of this script.
+    #
+    proc run {args} {
+	try {
+	    if {[llength $args] != 2} {
+		throw ARGS "inputTclScript templateFile"
+	    }
+	    lassign $args inputTclScript templateFile
+
+	    puts "Inserting $inputTclScript into $templateFile"
+	    set scriptLines [readScript $inputTclScript]
+	    updateTemplateFile $templateFile $scriptLines
+	    exit 0
+	} trap ARGS msg {
+	    puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\""
+	    exit 2
+	} trap BAD msg {
+	    puts stderr $msg
+	    exit 1
+	} trap POSIX msg {
+	    puts stderr $msg
+	    exit 1
+	} on error {- opts} {
+	    puts stderr [dict get $opts -errorinfo]
+	    exit 3
+	}
+    }
+}
+
+########################################################################
+#
+# Launch the main program
+#
+if {[info script] eq $::argv0} {
+    makeHeader::run {*}$::argv
+}
+
+# Local-Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/tools/mkVfs.tcl b/tools/mkVfs.tcl
new file mode 100644
index 0000000..cbfb81e
--- /dev/null
+++ b/tools/mkVfs.tcl
@@ -0,0 +1,99 @@
+proc cat fname {
+    set fname [open $fname r]
+    set data [read $fname]
+    close $fname
+    return $data
+}
+
+proc pkgIndexDir {root fout d1} {
+
+    puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \
+	      [file tail $d1]]
+    set idx [string length $root]
+    foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+        set f [file join $d1 $ftail]
+        if {[file isdirectory $f] && [string compare CVS $ftail]} {
+            pkgIndexDir $root $fout $f
+        } elseif {[file tail $f] eq "pkgIndex.tcl"} {
+      	    puts $fout "set dir \${VFSROOT}[string range $d1 $idx end]"
+	          puts $fout [cat $f]
+	      }
+    }
+}
+
+###
+# Script to build the VFS file system
+###
+proc copyDir {d1 d2} {
+
+    puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \
+	      [file tail $d2]]
+
+    file delete -force -- $d2
+    file mkdir $d2
+
+    foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+        set f [file join $d1 $ftail]
+        if {[file isdirectory $f] && [string compare CVS $ftail]} {
+            copyDir $f [file join $d2 $ftail]
+        } elseif {[file isfile $f]} {
+      	    file copy -force $f [file join $d2 $ftail]
+	          if {$::tcl_platform(platform) eq {unix}} {
+            		file attributes [file join $d2 $ftail] -permissions 0644
+      	    } else {
+            		file attributes [file join $d2 $ftail] -readonly 1
+	          }
+	      }
+    }
+
+    if {$::tcl_platform(platform) eq {unix}} {
+      	file attributes $d2 -permissions 0755
+    } else {
+	      file attributes $d2 -readonly 1
+    }
+}
+
+if {[llength $argv] < 3} {
+    puts "Usage: VFS_ROOT TCLSRC_ROOT PLATFORM"
+    exit 1
+}
+set TCL_SCRIPT_DIR [lindex $argv 0]
+set TCLSRC_ROOT    [lindex $argv 1]
+set PLATFORM       [lindex $argv 2]
+set TKDLL          [lindex $argv 3]
+set TKVER          [lindex $argv 4]
+
+puts "Building [file tail $TCL_SCRIPT_DIR] for $PLATFORM"
+copyDir ${TCLSRC_ROOT}/library ${TCL_SCRIPT_DIR}
+
+if {$PLATFORM == "windows"} {
+    set ddedll [glob -nocomplain ${TCLSRC_ROOT}/win/tcldde*.dll]
+    puts "DDE DLL $ddedll"
+    if {$ddedll != {}} {
+      	file copy $ddedll ${TCL_SCRIPT_DIR}/dde
+    }
+    set regdll [glob -nocomplain ${TCLSRC_ROOT}/win/tclreg*.dll]
+    puts "REG DLL $ddedll"
+    if {$regdll != {}} {
+      	file copy $regdll ${TCL_SCRIPT_DIR}/reg
+    }
+} else {
+    # Remove the dde and reg package paths
+    file delete -force ${TCL_SCRIPT_DIR}/dde
+    file delete -force ${TCL_SCRIPT_DIR}/reg
+}
+
+# For the following packages, cat their pkgIndex files to tclIndex
+file attributes ${TCL_SCRIPT_DIR}/tclIndex -readonly 0
+set fout [open ${TCL_SCRIPT_DIR}/tclIndex a]
+puts $fout {#
+# MANIFEST OF INCLUDED PACKAGES
+#
+set VFSROOT $dir
+}
+if {$TKDLL ne {} && [file exists $TKDLL]} {
+  file copy $TKDLL ${TCL_SCRIPT_DIR}
+  puts $fout [list package ifneeded Tk $TKVER "load \$dir $TKDLL"]
+}
+pkgIndexDir ${TCL_SCRIPT_DIR} $fout ${TCL_SCRIPT_DIR}
+close $fout
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index 5d21866..b0c2d8f 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -586,6 +586,7 @@ array set exclude_refs_map {
     scrollbar.n		{set}
     selection.n		{string}
     tcltest.n		{error}
+    text.n		{bind image lower raise}
     tkvars.n		{tk}
     tkwait.n		{variable}
     tm.n		{exec}
diff --git a/tools/uniClass.tcl b/tools/uniClass.tcl
index 9b4819d..86ec931 100644
--- a/tools/uniClass.tcl
+++ b/tools/uniClass.tcl
@@ -20,7 +20,7 @@ proc emitRange {first last} {
 	    set extranges 1
 	    set numranges 0
 	    set ranges [string trimright $ranges " \n\r\t,"]
-	    append ranges "\n#if TCL_UTF_MAX > 4\n    ,"
+	    append ranges "\n#if CHRBITS > 16\n    ,"
 	}
 	append ranges [format "{0x%x, 0x%x}, " \
 		$first $last]
@@ -33,7 +33,7 @@ proc emitRange {first last} {
 	    set extchars 1
 	    set numchars 0
 	    set chars [string trimright $chars " \n\r\t,"]
-	    append chars "\n#if TCL_UTF_MAX > 4\n    ,"
+	    append chars "\n#if CHRBITS > 16\n    ,"
 	}
 	append chars [format "0x%x, " $first]
 	incr numchars
@@ -66,7 +66,7 @@ proc genTable {type} {
     for {set i 0} {$i <= 0x10ffff} {incr i} {
     if {$i == 0xd800} {
 	# Skip surrogates
-	set i 0xdc00
+	set i 0xe000
     }
 	if {[string is $type [format %c $i]]} {
 	    if {$i == ($last + 1)} {
diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl
index 8125790..c712e62 100644
--- a/tools/uniParse.tcl
+++ b/tools/uniParse.tcl
@@ -272,6 +272,7 @@ static const unsigned char groupMap\[\] = {"
  *				 100 = subtract delta for title/upper
  *				 101 = sub delta for upper, sub 1 for title
  *				 110 = sub delta for upper, add delta for lower
+ *				 111 = subtract delta for upper
  *
  * Bits 8-31	Case delta: delta for case conversions.  This should be the
  *			    highest field so we can easily sign extend.
@@ -309,10 +310,14 @@ static const int groups\[\] = {"
 		}
 	    }
 	} elseif {$toupper} {
-	    # subtract delta for upper, add delta for lower
-	    set case 6
 	    set delta $toupper
-	    if {$tolower != $toupper} {
+	    if {$tolower == $toupper} {
+		# subtract delta for upper, add delta for lower
+		set case 6
+	    } elseif {!$tolower} {
+		# subtract delta for upper
+		set case 7
+	    } else {
 		error "New case conversion type needed: $toupper $tolower $totitle"
 	    }
 	} elseif {$tolower} {
diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress
new file mode 100644
index 0000000..fb7f173
--- /dev/null
+++ b/tools/valgrind_suppress
@@ -0,0 +1,126 @@
+{
+   TclCreatesocketAddress/getaddrinfo/calloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:calloc
+   ...
+   fun:getaddrinfo
+   fun:TclCreateSocketAddress
+}
+
+{
+   TclCreatesocketAddress/getaddrinfo/malloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:malloc
+   ...
+   fun:getaddrinfo
+   fun:TclCreateSocketAddress
+}
+
+{
+   TclpDlopen/load
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:calloc
+   ...
+   fun:dlopen
+   fun:TclpDlopen
+}
+
+{
+   TclpDlopen/load
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:malloc
+   ...
+   fun:dlopen
+   fun:TclpDlopen
+}
+
+{
+   TclpGetGrNam/__nss_next2/calloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:calloc
+   ...
+   fun:__nss_next2
+   ...
+   fun:TclpGetGrNam
+}
+
+{
+   TclpGetGrNam/__nss_next2/malloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:malloc
+   ...
+   fun:__nss_next2
+   ...
+   fun:TclpGetGrNam
+}
+
+{
+   TclpGetGrNam/__nss_systemd_getfrname_r/malloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:malloc
+   ...
+   fun:_nss_systemd_getgrnam_r
+   ...
+   fun:TclpGetGrNam
+}
+
+{
+   TclpGetPwNam/getpwname_r/__nss_next2/calloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:calloc
+   ...
+   fun:__nss_next2
+   ...
+   fun:TclpGetPwNam
+}
+
+{
+   TclpGetPwNam/getpwname_r/__nss_next2/malloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:malloc
+   ...
+   fun:__nss_next2
+   ...
+   fun:TclpGetPwNam
+}
+
+{
+   TclpGetPwNam/getpwname_r/_nss_systemd_getpwnam_r/malloc
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:malloc
+   ...
+   fun:_nss_systemd_getpwnam_r
+   ...
+   fun:TclpGetPwNam
+}
+
+{
+	TclpThreadExit/pthread_exit/calloc
+    Memcheck:Leak
+    match-leak-kinds: reachable
+	fun:calloc
+	...
+	fun:pthread_exit
+	fun:TclpThreadExit
+}
+
+{
+	TclpThreadExit/pthread_exit/malloc
+    Memcheck:Leak
+    match-leak-kinds: reachable
+	fun:malloc
+	...
+	fun:pthread_exit
+	fun:TclpThreadExit
+}
+